I have a code that should restore range formatting after applying few step.
Sub MyCode()
Sheets("My sheet").ListObjects("My Table").DataBodyRange.Copy
...
refreshing connection and calling function that applies stored formulas to table columns
...
Sheets("My sheet").[A10].PasteSpecial Paste:=xlPasteFormats
End sub
I got error PasteSpecial method on range failed
If I paste immediately, it works.
Is it possible to save range formatting as variable?
Here is an example on how to use variables to store the copy method and use it later. You can set the range to a variable CopyRange and use CopyRange.Copy to store it and later you can use it as the range was stored in the CopyRange and not lost along the way due to other processes running down the line.
Option Explicit
Sub CopyDataToTemplate()
Dim ws As Worksheet
Dim srcWB As Workbook
Dim destWB As Workbook
Dim srcWS As Worksheet
Dim destWS As Worksheet
Dim CopyRange As Variant
Dim i As Long, j As Long
Dim srcLRow As Long, destLRow As Long
Set destWB = Excel.Workbooks("DOLine_example.xlsx")
Set srcWB = ActiveWorkbook
Set srcWS = srcWB.ActiveSheet
Set destWS = destWB.Sheets("DOLine")
srcLRow = srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row
destLRow = destWS.Cells(destWS.Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
'loop through column 1 to 19
For i = 1 To 19
For j = 1 To 13
'loop through columns
If destWS.Cells(3, i).value = srcWS.Cells(1, j).value Then
' Copy column B to Column D as written in your code above
Set CopyRange = srcWS.Range(Cells(2, j), Cells(srcLRow, j))
CopyRange.Copy
' paste columns from one wb to Columns to another wb
destWS.Cells(destLRow, i).PasteSpecial Paste:=xlPasteAll, Transpose:=False
Application.CutCopyMode = False
End If
Next j
Next i
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
I work a cumulative report that grows daily up to about 150,000 rows of data. I am trying to run a macro that will move the data from one defined sheet to another defined sheet. Unfortunately, it is taking an extremely long time and leaves my Excel window frozen.
I have been staring at this code trying to make it work for our needs for so long that I haven't tried anything different.
Sub Move()
Application.ScreenUpdating = False
Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long
lastrow = Worksheets("From TaxWise").UsedRange.Rows.Count
lastrow2 = Worksheets("State").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = lastrow To 2 Step -1
If Not Range("L" & r).Value = "US" Then
Rows(r).Cut Destination:=Worksheets("State").Range("A" & lastrow2 + 1)
lastrow2 = lastrow2 + 1
Else:
End If
Next r
On Error Resume Next
ActiveWorkbook.Worksheets("From TaxWise").Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Not sure what I need to adjust as I feel my current code is running through 150,000 records line by line to identify, cut and move.
This code took about two seconds to run on 150000 records with about 3000 equal to US.
You'll need to alter it to match your setup. eg: Names of the various worksheets; cell ranges in case your tables don't start at A1, slightly different syntax if your data is in Excel Tables rather than just ranges, etc
It uses Excel's built-in autofilter
The destination sheet has all of the lines except for those with US.
Option Explicit
Sub noUS()
Dim wsSrc As Worksheet, wsDest As Worksheet
Dim rSrc As Range, rDest As Range
Const filterColumn As Long = 4 'Change to 12 for column L
Dim LRC() As Long
Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")
Set rDest = wsDest.Cells(1, 1)
wsDest.Cells.Clear
With wsSrc
'get last row and column of the source worksheet
LRC = LastRowCol(.Name)
'set the range
Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
'set the filter
'first turn it off
.AutoFilterMode = False
'now set it for the range
rSrc.AutoFilter _
field:=filterColumn, _
Criteria1:="<>US", _
visibledropdown:=False
End With
Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
rSrc.Copy rDest
'turn off the autofilter
wsSrc.AutoFilterMode = False
End Sub
'--------------------------------------------
Private Function LastRowCol(Worksht As String) As Long()
Application.Volatile
Dim WS As Worksheet, R As Range
Dim LastRow As Long, LastCol As Long
Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Not R Is Nothing Then
LastRow = R.Row
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Else
LastRow = 1
LastCol = 1
End If
End With
L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function
And if you want to have a separate sheet with the US rows, you can insert the following before the end of the Sub:
'now get the US rows
With wsSrc
Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
.AutoFilterMode = False
rSrc.AutoFilter _
field:=filterColumn, _
Criteria1:="US", _
visibledropdown:=False
Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
rSrc.Copy rUS
.AutoFilterMode = False
End With
I prefer to maintain the original data, rather than deleting stuff from the source. But, if you like, after you've done the above, and you are happy with the result, merely delete wsSrc
Edit
The above code modified so you wind up with, what I think you want, which is worksheets("State") containing all of the non-US items; and worksheets("From TaxWise") containing all of the US items.
Instead of deleting non-contiguous rows, a very slow process, we filter the rows we want to a new worksheet; delete the original worksheet, and rename the new sheet.
Don't try this at home without a backup of your original data.
Option Explicit
Sub noUS()
Dim wsSrc As Worksheet, wsDest As Worksheet, wsUS As Worksheet
Dim rSrc As Range, rDest As Range, rUS As Range
Const filterColumn As Long = 12
Dim LRC() As Long
Set wsSrc = Worksheets("From TaxWise")
Set wsDest = Worksheets("State")
Set rDest = wsDest.Cells(1, 1)
wsDest.Cells.Clear
With wsSrc
'get last row and column of the source worksheet
LRC = LastRowCol(.Name)
'set the range
Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
'set the filter
'first turn it off
.AutoFilterMode = False
'now set it for the range
rSrc.AutoFilter _
field:=filterColumn, _
Criteria1:="<>US", _
visibledropdown:=False
End With
Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
rSrc.Copy rDest
'turn off the autofilter
wsSrc.AutoFilterMode = False
'now get the US rows, may need to add worksheet
On Error Resume Next
Set wsUS = Worksheets("US")
If Err.Number = 9 Then
Worksheets.Add
ActiveSheet.Name = "US"
End If
Set wsUS = Worksheets("US")
Set rUS = wsUS.Cells(1, 1)
With wsSrc
Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
.AutoFilterMode = False
rSrc.AutoFilter _
field:=filterColumn, _
Criteria1:="US", _
visibledropdown:=False
Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
rSrc.Copy rUS
.AutoFilterMode = False
End With
'Delete Taxwise and rename US sheets
Application.DisplayAlerts = False
wsSrc.Delete
wsUS.Name = "From TaxWise"
Application.DisplayAlerts = True
End Sub
'--------------------------------------------
Private Function LastRowCol(Worksht As String) As Long()
Application.Volatile
Dim WS As Worksheet, R As Range
Dim LastRow As Long, LastCol As Long
Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Not R Is Nothing Then
LastRow = R.Row
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Else
LastRow = 1
LastCol = 1
End If
End With
L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function
You can filter and work with visible cells or you can avoid deleting rows inside your loop.
Say, for instance, that you have 500 cells that are not equal to US. You will then have 500 instances of copy/paste & deletions. This is highly inneficient.
Instead, add your target cells to a Union (collection of cells) and then outside of the loop, perform your operations on the collection. No matter how many rows are being targeted, you will have just one instance of copy, one instance of paste, and one instance of deletion.
Sub Moving()
Dim cs As Worksheet: Set cs = ThisWorkbook.Sheets("From TaxWise")
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("State")
Dim MoveMe As Range, myCell As Range, LR2 As Long
Dim LR As Long: LR = cs.Range("L" & cs.Rows.Count).End(xlUp).Row
For Each myCell In cs.Range("L2:L" & LR)
If myCell <> "US" Then
If Not MoveMe Is Nothing Then
Set MoveMe = Union(MoveMe, myCell)
Else
Set MoveMe = myCell
End If
End If
Next myCell
If Not MoveMe Is Nothing Then
LR2 = ps.Range("A" & ps.Rows.Count).End(xlUp).Row
MoveMe.EntireRow.Copy
ps.Range("A" & LR2).PasteSpecial xlPasteValues
MoveMe.EntireRow.Delete
End If
End Sub
Move Rows
Union Version
Option Explicit
Sub Move()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim rngU As Range, r As Long, lastrow2 As Long, lastrow As Long
On Error GoTo ProcedureExit
With Worksheets("From Taxwise")
lastrow = .Cells(.Rows.Count, "L").End(xlUp).row
For r = 2 To lastrow
If Not .Range("L" & r).Value = "US" Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(r, 1))
Else
Set rngU = .Cells(r, 1)
End If
End If
Next
End With
If Not rngU Is Nothing Then
With Worksheets("State")
lastrow2 = .Cells(.Rows.Count, "L").End(xlUp).row
rngU.EntireRow.Copy .Range("A" & lastrow2 + 1)
rngU.EntireRow.Delete
End With
Set rngU = Nothing
End If
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
I am currently trying to filter data and paste it into another sheet to a certain range but it is only posting the latest data row. How do I fix the code so that it selects all the rows with the code word and pastes it into the other sheet.
This is my code:
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long
lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Sheets("sheet1").Cells(i, 1) = "pp" Then
Sheets("sheet1").Range(Cells(i, 2), Cells(i, 5)).Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet5").Range("A11:A22")
End If
Next
End Sub
I think this is what you want.
Private Sub CommandButton1_Click()
Dim ws1 as Worksheet: Set ws1 = Thisworkbook.Sheets("Sheet1")
Dim ws2 as Worksheet: Set ws2 = Thisworkbook.Sheets("Sheet5")
Dim LRow1 As Long, LRow2 as Long, i As Long
LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If ws1.Cells(i, 1) = "pp" Then
ws1.Range(Cells(i, 1), Cells(i, 5)).Copy
ws2.Range("A" & LRow + 1).PasteSpecial xlPasteValues
End If
Next
End Sub
Here is a more effecient method using a For Each loop and one instance of Copy/Paste instead of 1 iteration for every matched cell.
Option Explicit
Sub Copy()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim TargetRange As Range, TargetCell As Range, CopyRange As Range
Set TargetRange = ws1.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
For Each TargetCell In TargetRange
If TargetCell = "pp" Then
If CopyRange Is Nothing Then
Set CopyRange = TargetCell.Resize(1, 4)
Else
Set CopyRange = Union(CopyRange, TargetCell.Resize(1, 4))
End If
End If
Next TargetCell
CopyRange.Copy
ws2.Range("A" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Another method would be to apply a filter for your target value pp and then copy/paste visible cells.
I have this code, by a responder who helped me to define my needs yesterday - but there somethings i want to change, but my vba skills are very low and dont know how and where to modify the code. I want it do 2 Things.
Right know it transferes data, i want it to copy it, over with the values that are calculated in the cells. I have some cells, where i have some formulas and it dosent follows with it. I just want the calculated value over. I dont know if i can use xlPasteValues somewhere to get what i want?
The second thing that i want is, when copying over, i want to be on top and the previous copies move Down, so the latest copy always are in the top.
Thank you before handed :)
Option Explicit
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
targetSheet.Columns.AutoFit
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function
Please give this a try...
The StartRow variable defines the destination row on targetSheet, you may change it as per your requirement.
Sub Copypastemeddata()
Dim wb As Workbook
Dim ws As Worksheet
Dim sourceCell As Range
Dim targetSheet As Worksheet
Dim StartRow As Integer
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Opgørsel")
Set sourceCell = ws.Range("D3") 'Cell with sheet names for copying to
StartRow = 1 'Destination row on targetSheet
With ws
Set targetSheet = wb.Worksheets(sourceCell.Text)
.Range("A1").CurrentRegion.Copy
targetSheet.Range("A" & StartRow).Insert shift:=xlDown
targetSheet.Range("A" & StartRow).PasteSpecial xlPasteValues
targetSheet.Columns.AutoFit
End With
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
substitute
Dim nextRow As Long
nextRow = GetLastRow(targetSheet, 1)
nextRow = IIf(nextRow = 1, 1, nextRow + 1)
.Range("A1").CurrentRegion.Copy targetSheet.Range("A" & nextRow)
with
With .Range("A1").CurrentRegion
targetSheet.Rows(1).Resize(.Rows.Count).Insert shift:=xlUp
targetSheet.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
What I want to achieve is to copy data from WS1 to WS3 based on certain criteria.
I have 2 worksheets:
WS1 = RAW DATA
WS2 = ATLAS DATA
In columns A of both there are unique identifiers. What I want to do is to create WS3=Reconciliation. Then look up values in WS2 against WS1. Where a match is found I want to copy row(s) from WS1 to WS3 that all
I have reverse engineered some code and came up with one below
Sub CopyAndPaste()
Dim x As String, CpyRng As Range
Dim mFIND As Range, mFIRST As Range
With Sheets("RAW DATA")
Range("A:A").Select
On Error Resume Next
End With
With Sheets("ATLAS DATA")
Set mFIND = .Range("A:A").Find(x, LookIn:=xlValues, LookAt:=xlWhole)
If Not mFIND Is Nothing Then
Set CpyRng = mFIND
Set mFIRST = mFIND
Do
Set CpyRng = Union(CpyRng, mFIND)
Set mFIND = .Range("A:A").FindNext(mFIND)
Loop Until mFIND.Address = mFIRST.Address
CpyRng.EntireRow.Copy Sheets("Rec").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End With
End Sub
Based on your description of your problem; try this
Option Explicit
Sub CopyAndPaste()
Application.ScreenUpdating = False
Dim i As Long, j As Long, lastRow1 As Long, lastRow2 As Long, cnt As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = ActiveWorkbook.Sheets("RAW DATA")
Set ws2 = ActiveWorkbook.Sheets("ATLAS DATA")
Set ws3 = ActiveWorkbook.Sheets("Reconciliation")
lastRow1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
lastRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
cnt = 1
For i = 1 To lastRow1
For j = 1 To lastRow2
If StrComp(CStr(ws2.Range("A" & j).Value), _
CStr(ws1.Range("A" & i).Value), _
vbTextCompare) = 0 Then
ws1.Activate
ws1.Rows(i).Select
Selection.Copy
ws3.Activate
ws3.Range("A" & cnt).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Application.CutCopyMode = False
cnt = cnt + 1
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub