Am newbie to VBA and trying to find dupliactes on column A and copy Column A, G and I to another sheet and used below code
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range, _
unionRng As Range
Dim i As Long, iOld As Long
Set wstSource = Worksheets("Final Product List")
Set wstOutput = Worksheets("INN Working")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With wstSource
Set rngMyData = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
With rngMyData
Set helperRng = .Offset(, rngMyData.Columns.Count - 1).Resize(, 1)
Set unionRng = .Cells(1000, 1000) 'set a "helper" cell to be used with Union method, to prevent it from failing the first time
End With
With helperRng
.FormulaR1C1 = "=row()" 'mark rows with ad ascending number (its own row number)
.Value = .Value
End With
With rngMyData.Resize(, rngMyData.Columns.Count + 1) 'enclose "helper" column
.Sort key1:=.Columns(1), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data to have all same columnA values grouped one after another
i = .Rows(1).Row 'start loop from data first row
Do While i < .Rows(.Rows.Count).Row
iOld = i 'set current row as starting row
Do While .Cells(iOld + 1, 1) = .Cells(iOld, 1) 'loop till first cell with different value
iOld = iOld + 1
Loop
If iOld - i > 0 Then Set unionRng = Union(unionRng, .Cells(i, 1).Resize(iOld - i + 1)) 'if more than one cell found with "current" value, then add them to "UnionRng" range
i = iOld + 1
Loop
Intersect(unionRng, rngMyData).EntireRow.Copy Destination:=wstOutput.Cells(1, 1) 'get rid of the "helper" cell via Intersect method
wstOutput.Columns(helperRng.Column).Clear 'delete "Helper" column pasted in wstOutput sheet
.Sort key1:=.Columns(4), Order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo ' sort data in wstSource back
End With
helperRng.Clear 'delete "helper" column, not needed anymore
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
The above code is throwing RunTime error '91'
Object variable or with block variable not set
If iOld - i > 0 Then Set unionRng = Union(unionRng, .Cells(i, 1).Resize(iOld - i + 1)) 'if more than one cell found with "current" value, then add them to "UnionRng" range
i = iOld + 1
End If
The End If was missing and VBA gives a poor message.
Related
Sub CopyRow()
'Declare variables
Dim sheetNo1 As Worksheet
Dim sheetNo2 As Worksheet
Dim FinalRow As Long
Dim Cell As Range
'Set variables
Set sheetNo1 = Sheets("EA Log")
Set sheetNo2 = Sheets("Commitments")
' Define destination sheets to move row
FinalRow1 = sheetNo2.Range("A" & sheetNo2.Rows.Count).End(xlUp).Row + 1
'Apply loop for column P until last cell with value
For Each Cell In sheetNo1.Range("P4:P" & sheetNo1.Cells(sheetNo1.Rows.Count, "P").End(xlUp).Row)
'Apply condition to match the "Signed" value
If Cell.Value = "Signed" Then
'Command to Copy and move to a destination Sheet "Commitments"
sheetNo1.Range(sheetNo1.Cells(Cell.Row, 2), sheetNo1.Cells(Cell.Row, 3)).Copy _
Destination:=sheetNo2.Range("A4:A" & FinalRow1)
sheetNo1.Range(sheetNo1.Cells(Cell.Row, 14), sheetNo1.Cells(Cell.Row, 14)).Copy _
Destination:=sheetNo2.Range("C4:C" & FinalRow1)
sheetNo1.Range(sheetNo1.Cells(Cell.Row, 1), sheetNo1.Cells(Cell.Row, 1)).Copy _
Destination:=sheetNo2.Range("E4:E" & FinalRow1)
sheetNo1.Range(sheetNo1.Cells(Cell.Row, 25), sheetNo1.Cells(Cell.Row, 25)).Copy _
Destination:=sheetNo2.Range("D4:D" & FinalRow1)
FinalRow1 = FinalRow1 + 1
End If
Next Cell
Application.ScreenUpdating = True
End Sub
Good morning,
currently I have this code to delete rows without due date (Column J) and amount paid=0 (Column H).
Sub delete_rows()
Range("A1").End(xlDown).Select
Sheets("AA").Select
Range("J2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-5]=0,"""",RC[-5])"
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J500"), Type:=xlFillDefault
Range("J2").End(xlDown).Select
Range("K2").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "J").End(xlUp).Row To 2 Step -1
If .Cells(line, "J") = "" Then
.Rows(line).Delete
End If
Next linha
End With
Application.ScreenUpdating = True
ActiveCell.FormulaR1C1 = "=IF(RC[-4]="""","""",RC[-4])"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K500"), Type:=xlFillDefault
Range("K2").End(xlDown).Select
Range("J1").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "K").End(xlUp).Row To 2 Step -1
If .Cells(line, "K") = "" Then
.Rows(line).Delete
End If
Next line
End With
Application.ScreenUpdating = True
End sub()
I created a code with a defined number of lines...however it takes a long time for the code to run, because sometimes the number of lines is small and it always runs the 500 lines. What's the way to set the code so that it looks for the last filled row in column A, and then eliminate the rows where column H has values =0 and in column J no values?
Please check: find last cell. Also have a look at: avoid select.
Afterwards, I think you should be able to understand the following code, which should get you the required result:
Sub test()
Application.ScreenUpdating = False
'declare your variables
Dim ws As Worksheet
Dim Rng1 As Range, Rng2 As Range
Dim i As Long, lastRow As Long
Set ws = Sheets("AA")
With ws
'get last row in
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'set ranges for loop
Set Rng1 = Range(.Cells(2, "H"), .Cells(lastRow, "H"))
Set Rng2 = Range(.Cells(2, "J"), .Cells(lastRow, "J"))
'reverse loop
For i = Rng1.Rows.Count To 1 Step -1
'check conditions for cell in "H" and "J"
If Rng1.Cells(i) = 0 And Rng2.Cells(i) = "" Then
'defined ranges start at row 2, hence +1
ws.Rows(i + 1).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
I am using below code in one workbook as the following:
(1) Match a range on SheetA against a range on SheetB.
(2) If the data found on SheetB, then some values will be inserted on SheetB and Sheet Log.
(3) The matched data (rows) on SheetB will be copied to Sheet Result and Autofit.
(4) The matched data (rows) on SheetB will be cleared. (cut & paste is not applicable).
The count of values on the first range in SheetA is normally 7 or 8 and this macro was as fast as it takes 2 seconds to finish all that steps.
I tried to put 146 values on the first range, but the macro turned to be very slow and it took 35 seconds to finish.
Please, how to speed up and optimize this macro?
Note: there is no problem at all to change match code or copy, paste, autofit and clear code.
Link for the full macro and sheet on the first comment.
Sub Match_Copy()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant
For Each Cell In WorkOrder
Match_A = Application.Match(Cell.value, Auto_Data, 0)
If Not IsError(Match_A) Then
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
If ws.name = "SheetB" Then 'Put Data of Close in Log Sheet
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 3).value = _
Array(Application.UserName, Now, Cell)
End If
End If
Next Cell
'----------------------------- Copy, Paste, AutoFit and Clear Code
Dim StatusColumn As Range
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Copy
Dim DestRng As Range
Set DestRng = Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1)
DestRng.PasteSpecial xlPasteValues
DestRng.Rows.AutoFit
If DestRng.Rows.RowHeight < 45 Then DestRng.Rows.RowHeight = 45
End If
Next Cell
For Each Cell In StatusColumn
If Cell.value = "Close" Then
Cell.EntireRow.Clear
End If
Next Cell
'-----------------------------
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End sub
Please, check the next adapted code. It uses arrays for faster iteration and for faster results return. Also, setting the row height for each cell consumes Excel resources. I commented some rows but no time now for everything. If something unclear, please do not hesitate to ask for clarifications:
Sub Run_Close()
Dim dStart As Double: dStart = Timer
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'------------------
Dim lastR As Long: lastR = Sheets("SheetA").Cells(Rows.Count, "A").End(xlUp).Row
Dim Auto_Data As Range: Set Auto_Data = Sheets("SheetA").Range("A2:A" & lastR)
Dim Count_Auto_Data As Long: Count_Auto_Data = WorksheetFunction.CountA(Auto_Data)
If Count_Auto_Data = 0 Then Exit Sub
With Auto_Data
.NumberFormat = "General"
.Value = .Value
End With
'------------------
Sheets("Result").AutoFilter.ShowAllData
Dim ws As Worksheet, arrWsFin, arrLog, k As Long
For Each ws In Sheets(Array("SheetB")) 'There are another 3 Sheets
ws.AutoFilter.ShowAllData
Dim LastRow As Long: LastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Dim WorkOrder As Range: Set WorkOrder = ws.Range("A3:A" & LastRow)
Dim arrWO: arrWO = WorkOrder.Value2 'place the range in an array for faster iteration
ReDim arrWsFin(1 To LastRow, 1 To 3) 'redim array to keep the modifications in ws sheet
ReDim arrLog(1 To 3, 1 To LastRow): k = 1 'redim array to keep maximum modif of ws sheet
'----------------------------- Match, Code
Dim Cell As Object, Match_A As Variant, i As Long
For i = 1 To UBound(arrWO)
Match_A = Application.Match(arrWO(i, 1), Auto_Data, 0)
If Not IsError(Match_A) Then
arrWsFin(i, 1) = "Close": arrWsFin(i, 2) = Now: arrWsFin(i, 3) = ws.name
If ws.name = "SheetB" Then 'Put Data of Close in the array for further return at once
arrLog(1, k) = Application.UserName: arrLog(2, k) = Now: arrLog(3, k) = arrWO(i, 1): k = k + 1
End If
End If
Next i
ws.Range("G2").Resize(UBound(arrWsFin), UBound(arrWsFin, 2)).Value = arrWsFin
If k > 1 Then
ReDim Preserve arrLog(1 To 3, 1 To k - 1)
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(arrLog, 2), UBound(arrLog)).Value = Application.Transpose(arrLog)
End If
'----------------------------- Copy, Paste and AutoFit, Code
Dim StatusColumn As Range, totRng As Range, lastCol As Long, arrSt, arrResult, arrRow, j As Long
lastR = ws.Cells(Rows.Count, "G").End(xlUp).Row
Set StatusColumn = ws.Range("G2", ws.Cells(Rows.Count, "G").End(xlUp))
arrSt = StatusColumn.Value2 'place the range in an array for faster iteration
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Set totRng = ws.Range("A2", ws.Cells(lastR, lastCol)) 'total range to extract the row slice
Dim rngClearCont As Range
ReDim arrResult(1 To lastCol, 1 To lastR): k = 1
For i = 1 To UBound(arrSt)
If arrSt(i, 1) = "Close" Then
arrRow = totRng.Rows(i).Value
'load arrResult array:
For j = 1 To lastCol
arrResult(j, k) = arrRow(1, j)
Next
k = k + 1
If rngClearCont Is Nothing Then
Set rngClearCont = StatusColumn.Cells(i) 'set the range necessary to clear rows at the end
Else
Set rngClearCont = Union(rngClearCont, StatusColumn.Cells(i))
End If
End If
Next i
If k > 1 Then
ReDim Preserve arrResult(1 To lastCol, 1 To k - 1)
With Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(arrResult, 2), _
UBound(arrResult))
.Value = Application.Transpose(arrResult)
.Rows.RowHeight = 45
End With
rngClearCont.EntireRow.ClearContents
End If
'-----------------------------
Next ws
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Time taken: " & Format(Timer - dStart, "0.00s")
End Sub
It should take less than a second...
The root of your issue is that you are making many edits to the worksheet. One of the first ways to speed up VBA code is to reduce the number of times you write data to the sheet.
Rather than writing your data to the sheet every time in a For Each loop, add all of your data to an Array and then write that entire Array to the sheet(s) at once. This way, you don't have to write multiple times for every For Each loop, but only once.
I cannot guarantee that this is the only reason your code is "sub-optimal" but it's a good place to start to improve performance times.
While writing to the sheet does take time, the main problem here is the copy/paste part.
If you, after the row
Cell.Offset(, 6).Resize(1, 3).value = Array("Close", Now, ws.name) 'Put Data of Close in every Area
Put something like:
Sheets("Result").Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 9).value = Array(Cell, , , , , , "Close", Now, ws.name)
And then remove the copy/paste part completely, you should be able to run it almost instantly.
Its update to my prior question for which i missed to add point saying that column 3 Header data might start with space or at the end or any additional text in it hence we should try it with contains.
Count results should be shown in a new sheet for all filter entities like 3 (Index) 3(Level) AIUH (Entity Name) 3(Count) with additional column to the end of the table and rows will not be
I apologize for my bad etiquette and wasting experts time on this to work again.
Here is the previous code for reference:
Sub xferAscendingFiltered()
Dim cnt As Long, rHDR As Range, rDELs As Range, vFLTRs As Variant
'fill this array with your 40-50 Header values
vFLTRs = Array("AIS", "BBS", "AIUH", _
"XXX", "YYY", "ZZZ")
With Worksheets("Sheet2")
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
'filter on all the values in the array
.AutoFilter Field:=3, Criteria1:=vFLTRs, Operator:=xlFilterValues
'walk through the visible rows
With .Resize(.Rows.Count - 1, 1).Offset(0, 2)
Set rHDR = .Find(What:=Chr(42), After:=.Cells(1, 1), _
SearchOrder:=xlByRows, SearchDirection:=xlNext)
'seed the rows to delete so Union can be used later
If rHDR.Row > 1 Then _
Set rDELs = rHDR
Do While rHDR.Row > 1
cnt = 0
'increase cnt by both visible and hidden cells
Do
cnt = cnt + 1
Loop While rHDR.Offset(cnt, -1).Value2 > rHDR.Offset(cnt - 1, -1).Value2 And _
Intersect(rHDR.Offset(cnt, 0), .SpecialCells(xlCellTypeVisible)) Is Nothing
'transfer the values and clear the original(s)
With .Cells(rHDR.Row, 1).Resize(cnt, 3).Offset(0, -2)
'transfer the values
Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
'set teh count
Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1 - cnt, 3) = cnt
Set rDELs = Union(rDELs, .Cells)
rHDR.Clear
End With
'get next visible Header in column C
Set rHDR = .FindNext(After:=.Cells(1, 1))
Loop
.AutoFilter
End With
End With
'remove the rows
rDELs.EntireRow.Delete
End With
End Sub
Prior question link:
Thanks experts
Wildcards in your filter code.
To use contains using a variable, this should work as the criteria to find:
This will loop through the array and place a 1 beside a match, then filter column D for 1
Sub xferAscendingFiltered()
Dim cnt As Long, rHDR As Range, rDELs As Range, vFLTRs As Variant
'-------------
Dim rng As Range, cel As Range, LstRw As Long, sh As Worksheet, i '<<<<<
Set sh = Sheets("Sheet2") '<<<<<<<<
'---------------
'fill this array with your 40-50 Header values
vFLTRs = Array("AIUH", "ASC", "ABB", "BBS", "YYY", "ZZZ")
'vFLTRs = Array("*BBS*", "*ABB*", "*ASC*", "*AIUH*")
With sh
'-----------------------------------<<<<<<
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rng = Range("C2:C" & LstRw)
'----Loop Through Array-----
For i = LBound(vFLTRs) To UBound(vFLTRs)
For Each cel In rng.Cells
If cel Like "*" & vFLTRs(i) & "*" Then
cel.Offset(, 1) = 1
End If
Next cel
Next i
With .Cells(1, 1).CurrentRegion
'filter on all the values in the array
.AutoFilter Field:=4, Criteria1:=1
'-----------------------------------<<<<<<<<<
'walk through the visible rows
With .Resize(.Rows.Count - 1, 1).Offset(0, 2)
Set rHDR = .Find(What:=Chr(42), After:=.Cells(1, 1), SearchOrder:=xlByRows, SearchDirection:=xlNext)
'seed the rows to delete so Union can be used later
If rHDR.Row > 1 Then Set rDELs = rHDR
Do While rHDR.Row > 1
cnt = 0
'increase cnt by both visible and hidden cells
Do
cnt = cnt + 1
Loop While rHDR.Offset(cnt, -1).Value2 > rHDR.Offset(cnt - 1, -1).Value2 And _
Intersect(rHDR.Offset(cnt, 0), .SpecialCells(xlCellTypeVisible)) Is Nothing
'transfer the values and clear the original(s)
With .Cells(rHDR.Row, 1).Resize(cnt, 3).Offset(0, -2)
Worksheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(.Rows.Count, .Columns.Count) = .Value
Set rDELs = Union(rDELs, .Cells)
rHDR.Clear
End With
'get next visible Header in column C
Set rHDR = .FindNext(After:=.Cells(1, 1))
Loop
.AutoFilter
End With
End With
'remove the rows
rDELs.EntireRow.DELETE
End With
End Sub
Right people, I’m back again for some more help. I have a workbook where I add new worksheets every month with information which is exactly the same as before in structure. In column A, I have invoice numbers then details from columns B:J. In columns K & L there are comments manually added for all outstanding issues. What I want to do is be able to lookup invoices against the last worksheet and then copy comments in columns K & L into the new worksheet.
I have tried to create a bit of code but nothing is coming off it. The ActiveSheet is the newly created without comments. So i want to lookup invoice numbers in columns A and copy columns K & L where a match is found from last worksheet to columns K&L of the activesheet. I hope I make sense and thank you for helping
Option Explicit
Sub FindCopy_all()
Dim calc As Long
Dim Cel As Range
Dim LastRow As Long
Dim rFound As Range
Dim LookRange As Range
Dim CelValue As Variant
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of data ActiveSheet, Col A
LastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
' Set range to look in
Set LookRange = ActiveSheet.Range("A1:A" & LastRow)
' Loop on each value (cell)
For Each Cel In LookRange
' Get value to find
CelValue = Cel.Value
' Look on previous sheet
With Sheets(Sheets.Count - 3)
Set rFound = .Cells.Find(What:=CelValue, _
After:=.Cells(1, 1), LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
' Reset
On Error GoTo endo
' Not found, go next
If rFound Is Nothing Then
GoTo NextCel
Else
' Found. last sheet, Col K & L to Active Sheet found Row, Col K & L
.Cells(rFound.Row, 11, 12).Resize(, 2).Copy ActiveSheet.Cells(Cel.Row, 11, 12)
End If
End With
NextCel:
Next Cel
Set rFound = Nothing
'Reset
endo:
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
You are in a with statement on the previous sheet and no activesheet statement exist. Use:
.Cells(rFound.Row, 11).Resize(,2).Copy activesheet.Cells(cel.Row, 11)
Also, you shouldn't need On Error Resume Next as the range returned will be nothing and also be sure you set rFound = nothing after you've completed each find.
NextCel:
set rFound = nothing
my code:
Option Explicit
Sub FindCopy_all()
Dim calc As Long
Dim Cel As Range
Dim LastRow As Long
Dim rFound As Range
Dim LookRange As Range
Dim CelValue As Variant
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of data ActiveSheet, Col A
LastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
' Set range to look in
Set LookRange = ActiveSheet.Range("A1:A" & LastRow)
' Loop on each value (cell)
For Each Cel In LookRange
' Get value to find
CelValue = Cel.Value
' Look on previous sheet
With Sheets(Sheets.Count - 1)
Set rFound = .Range("A:A").Find(What:=CelValue, _
After:=.Cells(1, 1), LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
' Not found, go next
If rFound Is Nothing Then
GoTo NextCel
Else
' Found. last sheet, Col K & L to Active Sheet found Row, Col K & L
.Cells(rFound.Row, 11).Resize(, 2).Copy ActiveSheet.Cells(Cel.Row, 11)
End If
End With
NextCel:
Set rFound = Nothing
Next Cel
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
My suggestion is that your VBA code puts VLOOKUP formulas in the new worksheet to retrieve the invoice information like this:
activesheet.Cells(cel.Row, 11).formula="=VLOOKUP(...)"
then in order to replace the formulas with text your code could use
activesheet.Cells(cel.Row, 11).Copy
followed by
activesheet.Cells(cel.Row, 11).PasteSpecial xlPasteValues to replace the formulas with just text values
try my code
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of data ActiveSheet, Col A
LastRow = ActiveSheet.Cells(activesheet.rows.count, 1).End(xlUp).Row
' Set VLOOKUP formula, search on the other sheet for the value in column A, return the value matchiung from column 11, and use EXACT MATCH.
'
' =VLOOKUP(A:A,Sheet1!A:L,11,FALSE) ' example
'
range("K1:K" & lastRow).formula="=VLOOKUP(A:A," & sheets(Worksheets.count-1).name & "!A:L,11, FALSE)"
activesheet.calculate
range("K1:K" & lastRow).copy
range("K1:K" & lastRow).pastespecial xlpastevalues ' remove the formulas
that should get you started, try stepping through that and check the VLOOKUP is acting on the right columns and let us know how you get on
Philip