Optimize this VBA lookup loop in Excel - arrays

I want to optimize the following code, as it is very slow.
I am using the code found in this answer:
https://stackoverflow.com/a/27108055/1042624
However, it is very slow when looping through +10k rows. Is it possible to optimize my code below? I have tried to modify it a bit, but it does not seem to work.
Sub DeleteCopy2()
Dim LastRow As Long
Dim CurRow As Long
Dim DestLast As Long
Dim strSheetName As String
Dim arrVal() As Long
Application.ScreenUpdating = False
Application.Calculation = xlManual
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
LastRow = Sheets("MatchData").Range("A" & Rows.Count).End(xlUp).Row
DestLast = Sheets(strSheetName).Range("A" & Rows.Count).End(xlUp).Row
ReDim arrVal(2 To LastRow) ' Headers in row 1
For CurRow = LBound(arrVal) To UBound(arrVal)
If Not Sheets(strSheetName).Range("A2:A" & DestLast).Find(Sheets("MatchData").Range("A" & CurRow).Value, LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then
Sheets("MatchData").Range("A" & CurRow).Value = ""
Else
End If
Next CurRow
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

Can you try this for me? I have commented the code so that you will not have a problem understanding it. Also check how much time it takes for 10k+ rows
Logic
Store search values in array 1
Store destination values in array 2
Loop through the first array and check if it is present in the second array. If present, clear it
Clear the search values from sheet1
Output the array to the sheet1
Sort Col A so that the blanks go down.
Code
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long, i As Long
Dim MArr As Variant, DArr As Variant
Dim strSheetName As String
Dim rng As Range
strSheetName = "Sheet2" '"Week " & IsoWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A2:A" & lRow)
MArr = rng.Value
End With
'~~> Store destination values in the 2nd array
With wbDestSheet
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
DArr = .Range("A2:A" & lRow).Value
End With
'~~> Check if the values are in the other array
For i = LBound(MArr) To UBound(MArr)
If IsInArray(MArr(i, 1), DArr) Then MArr(i, 1) = ""
Next i
With wbMatch
'~~> Clear the range for new output
rng.ClearContents
'~~> Output the array to the worksheet
.Range("A2").Resize(UBound(MArr), 1).Value = MArr
'~~> Sort it so that the blanks go down
.Columns(1).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End With
End Sub
'~~> function to check is a value is in another array
Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim j As Long
For j = 1 To UBound(arr, 1)
On Error Resume Next
IsInArray = Application.Match(stringToBeFound, Application.Index(arr, , i), 0)
On Error GoTo 0
If IsInArray = True Then Exit For
Next
End Function
Edit
Another way. Based on the sample file, this code runs in approx 1 minute.
Start : 8/4/2016 08:59:36 PM
End : 8/4/2016 09:00:47 PM
Logic:
It uses CountIf to check for duplicates and then deletes the duplicates using .Autofilter
Sub Sample()
Dim wbMatch As Worksheet, wbDestSheet As Worksheet
Dim lRow As Long
Dim strSheetName As String
Dim rng As Range
Debug.Print "Start : " & Now
strSheetName = "Week " & ISOWeekNum(Format(Date)) - 1
'~~> Set your worksheets
Set wbMatch = Sheets("MatchData")
Set wbDestSheet = Sheets(strSheetName)
'~~> Store search values in 1st array
With wbMatch
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Columns(2).Insert
Set rng = .Range("B2:B" & lRow)
lRow = wbDestSheet.Range("A" & wbDestSheet.Rows.Count).End(xlUp).Row
rng.Formula = "=COUNTIF('" & strSheetName & "'!$A$1:$A$" & lRow & ",A2)"
DoEvents
rng.Value = rng.Value
.Range("B1").Value = "Temp"
'Remove any filters
.AutoFilterMode = False
With .Range("A1:E" & lRow) 'Filter, offset(to exclude headers) and delete visible rows
.AutoFilter Field:=2, Criteria1:=">0"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
'Remove any filters
.AutoFilterMode = False
.Columns(2).Delete
End With
Debug.Print "End : " & Now
End Sub

Looks like #SiddarthRout and I were working in parallel...
My code example below executes in less than 2 secs (eyeball estimate) over almost 12,000 rows.
Option Explicit
Sub DeleteCopy2()
Dim codeTimer As CTimer
Set codeTimer = New CTimer
codeTimer.StartCounter
Dim thisWB As Workbook
Dim destSH As Worksheet
Dim matchSH As Worksheet
Set thisWB = ThisWorkbook
Set destSH = thisWB.Sheets("Week 32")
Set matchSH = thisWB.Sheets("MatchData")
Dim lastMatchRow As Long
Dim lastDestRow As Long
lastMatchRow = matchSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
lastDestRow = destSH.Range("A" & matchSH.Rows.Count).End(xlUp).Row
'--- copy working data into memory arrays
Dim destArea As Range
Dim matchData As Variant
Dim destData As Variant
matchData = matchSH.Range("A1").Resize(lastMatchRow, 1)
Set destArea = destSH.Range("A1").Resize(lastDestRow, 1)
destData = destArea
Dim i As Long
For i = 2 To lastDestRow
If Not InMatchingData(matchData, destData(i, 1)) Then
destData(i, 1) = ""
End If
Next i
'--- write the marked up data back to the worksheet
destArea = destData
Debug.Print "Destination rows = " & lastDestRow
Debug.Print "Matching rows = " & lastMatchRow
Debug.Print "Execution time = " & codeTimer.TimeElapsed & " secs"
End Sub
Private Function InMatchingData(ByRef dataArr As Variant, _
ByRef dataVal As Variant) As Boolean
Dim i As Long
InMatchingData = False
For i = LBound(dataArr) To UBound(dataArr)
If dataVal = dataArr(i, 1) Then
InMatchingData = True
Exit For
End If
Next i
End Function
The timing results from my code are (using the timer class from this post ):
Destination rows = 35773
Matching rows = 23848
Execution time = 36128.4913359179 secs

Related

Subscript out of range when trying to loop through array to read values

I have a string of predefined worksheets, that I need to run specific code for. I get a compile error.
The code is set up to copy data from one sheet to another.
How do I do the same for multiple sheets?
When I step through the code sht is showing the MHP60,MHP61,MHP62 and not just MHP60.
I get a subscript out of range error.
Sub Prepare_CYTD_Report()
Dim addresses() As String
Dim addresses2() As String
Dim SheetNames() As String
Dim SheetNames2() As String
Dim wb1 As Workbook, wb2 As Workbook
Dim my_Filename
'Declare variables for MHP60, MHP61, MHP62 Trial Balance Values
Dim i, lastcol As Long
Dim tabNames, cell As Range
Dim tabName As String
Dim sht As Variant
addresses = Strings.Split("A9,A12:A26,A32:A38,A42:A58,A62:A70,A73:A76,A83:A90", ",") 'Trial Balance string values
addresses2 = Strings.Split("G9,G12:G26,G32:G38,G42:G58,G62:G70,G73:G76,G83:G90", ",") 'Prior Month string values
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
'SheetNames2 = Strings.Split("MHP60-CYTDprior,MHP61-CYTDprior,MHP62-CYTDprior")
Set wb1 = ActiveWorkbook 'Revenue & Expenditure Summary Workbook
'*****************************Open CYTD files
my_Filename = Application.GetOpenFilename(fileFilter:="Excel Files,*.xl*;*.xm*", Title:="Select File to create CYTD Reports")
If my_Filename = False Then
Exit Sub
End If
Application.ScreenUpdating = False
Set wb2 = Workbooks.Open(my_Filename)
'*****************************Load Column Header Strings & Copy Data
For Each sht In SheetNames
lastcol = wb1.Sheets(sht).Cells(5, Columns.Count).End(xlToLeft).Column
On Error Resume Next
Set tabNames = wb1.Sheets(sht).Cells(4, 3).Resize(1, lastcol - 2).SpecialCells(xlCellTypeConstants)
'actual non-formula text values on row 4 from column C up to column lastCol'
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "No headers were found on row 4 of MHP60", vbCritical
Exit Sub
End If
For Each cell In tabNames
tabName = Strings.Trim(cell.Value2)
'dedicated variable in case of requirement for further parsing (space/comma elimination?)'
If CStr(wb1.Sheets(sht).Evaluate("ISREF('[" & wb2.Name & "]" & tabName & "'!$A$1)")) = "True" Then
'If wb2 has a tab named for the value in tabName
For i = 0 To UBound(addresses)
wb2.Sheets(tabName).Range(addresses(i)).Value2 = wb1.Sheets(sht).Range(addresses(i)).Offset(0, cell.Column - 1).Value2
'Debug.Print "data for " & wb2.Sheets(tabName).Range(addresses(i)).Address(, , , True) & " copied from " & wb1.Sheets("MHP60").Range(addresses(i)).Offset(0, cell.Column - 1).Address(, , , True)
Next i
Else
Debug.Print "A tab " & tabName & " was not found in " & wb2.Name
End If
Next cell
Next sht
MsgBox "CYTD Report Creation Complete", vbOKOnly
Application.ScreenUpdating = True
End Sub
Split by what?
SheetNames = Strings.Split("MHP60,MHP61,MHP62")
Split by comma? Then use the following instead:
SheetNames = Strings.Split("MHP60,MHP61,MHP62", ",")
Alternative
Dim SheetNames() As Variant ' needs to be Variant to work with Array()
SheetNames = Array("MHP60", "MHP61", "MHP62")
This should be quicker as your macro does not need to split the string and has it as array directly.

Using XLOOKUP in two different Sheets and having a variable array extent (VBA Coding)

Hello there I am very new to VBA coding and coding in general so I hope you can come up with a quick answer to my problem.
I am trying to get a XLookup-Formula into my vba-Code. The code is referencing to another Sheet ("Chart Plan" and is supposed to take the values in column "D" and "E" (starting from row 2) as fixed arrays down to the last row for the "Lookup array" and "return array". I want this to be variable as the "Chart Plan" is updated with different row numbers according to what I am working on. The formula then is supposed to return the values into the active worksheet (Column "J") and go through all the rows ("B" given as RC[-8] = Lookup value).
The problem, I guess, is that I don't really know how the syntax is for giving the arrays into the formula or is it something else entirly? Mixing between RC-Annotation and A1-Annotation maybe?
Thank you.
Dim aEndKP As Variant
Dim aStartKP As Variant
Dim aCN As Variant
Sub ChartPlanScript()
Dim row As Long
Dim last_row As Long
Dim rng As Range
Dim ws As Worksheet
'Array End KP
LReKP = Sheets("Chart Plan").Cells(Rows.Count, "D").End(xlUp).row
aEndKP = Sheets("Chart Plan").Range("D2:D" & LReKP)
'Array Start KP
LRsKP = Sheets("Chart Plan").Cells(Rows.Count, "E").End(xlUp).row
aStartKP = Sheets("Chart Plan").Range("C2:C" & LRsKP)
'Array Chart Plan
LRCN = Sheets("Chart Plan").Cells(Rows.Count, "E").End(xlUp).row
aCN = Sheets("Chart Plan").Range("E2:E" & LRCN)
Set ws = Sheets(1)
ws.Activate
last_row = ws.Range("A5000").End(xlUp).row
For row = 2 To last_row
If Range("A" & row).Value > 0 Then
ws.Range("J" & row).Value = "=XLOOKUP(RC[-8],[aEndKP],[aCN],,1,1)"
Else
ws.Range("J" & row).Value = ""
End If
Next row
End Sub
I don't have XLOOKUP on my version of Excel but this would be using VLOOKUP
Option Explicit
Sub ChartPlanScript()
Dim ws As Worksheet
Dim i As Long, last_row As Long
Dim sCN As String
'Chart Plan
With Sheets("Chart Plan")
last_row = .Cells(Rows.Count, "D").End(xlUp).row
sCN = "'Chart Plan'!" & .Range("D2:E" & last_row).Address
End With
Set ws = Sheets(1)
ws.Activate
last_row = ws.Range("A5000").End(xlUp).row
For i = 2 To last_row
If ws.Cells(i, "A") > 0 Then
ws.Range("J" & i).Formula = "=VLOOKUP(B" & i & "," & sCN & ",2,0)"
Else
ws.Cells(i, "J") = ""
End If
Next
MsgBox i - 1 & " rows processed"
End Sub

The below code is not running for all matching cases of "i" but only for the very first matched Item

In worksheet wsb,I am trying to copy column B and Column having ParName in header and pasting it to columns B & H respectively of worksheet wso. The problem is It's running only for first Item and also for the first matched value of i for that item and not for all the matched item-i values.
Dim ws, wsa, wsb, wsc, wso As Worksheet
Dim index1b, LastRow, MOLastRow, wsoLastRow As Long
Dim ColLtr1b As Variant
Dim MoNameArr
Set wsb = Workbooks(Y).Sheets("REF")
wsb.Activate
LastRow = GetLastRow(wsb, 2)
Arr = Array("Abc", "Def")
Set wso = Workbooks(W).Sheets("Output")
For Each Item In Arr
For i = 2 To LastRow
If Cells(i, 2).Value = Item Then
wsb.Activate
ParName = wsb.Cells(i, 3).Value
Set wsc = Workbooks(M).Sheets(Item)
wsc.Activate
index1b = Application.Match(ParName, wsc.Rows(1), 0)
If Not IsError(index1b) Then
ColLtr1b = Replace(wsc.Cells(1, index1b).Address(True, False), "$1", "")
MOLastRow = wsc.Cells(Rows.Count, 2).End(xlUp).Row
Range("B2:B" & GetLastRow(wsc, 2)).Copy
wso.Activate
wsoLastRow = GetLastRow(wso, 2)
Range("B" & wsoLastRow + 1).Select
ActiveSheet.Paste
wsc.Activate
Range(ColLtr1b & "2:" & ColLtr1b & GetLastRow(wsc, 2)).Copy
wso.Activate
Range("H" & wsoLastRow + 1).Select
ActiveSheet.Paste
End If
End If
Next i
Next Item
Declare your variables like this:
Dim ws As Worksheet, wsa As worksheet, wsb as Worksheet
Dim wsc as Worksheet, wso As Worksheet
Dim index1b as Long, LastRow as Long, MOLastRow as Long, wsoLastRow As Long
Then start debugging with pressing F8. It goes line by line and you may see where is the problem in the nested loop. It can be in one of these 3:
you need to write Trim(Cells(i, 2)) in the If Cells(i, 2).Value = Item Then condition;
you are not calculating LastRow correctly;
you have On Error Resume Next somewhere in your code and you are entering an error w/o noticing;

Put results from Find-function (including extra columns for each result) into array vba

This question is based on a tip I got in the forum some other day, but since this completely changed the problem I'm creating a new post (it seemed a much better solution than the one I proposed but I'm having some issues).
The rationale of my code is to search up and find entries based on ID in column A (from criteria input in txtbox); if the row matches the search criteria then I want the data from column A to J for that entry to be stored in a dynamic array. All the matching entries will be stored there. This array will be used to display all the relevant entries in a listbox in a userform.
The code is the following:
Private Sub cmdFind_Click()
Dim sht As Worksheet
Dim lastrow As Variant
Dim strSearch As String
Dim aCell As Range
Dim row_number As Integer
Dim item_in_review As Variant
Dim y As Integer
Dim Arr() As Variant
y = lstSearch.ListCount
Set sht = ActiveWorkbook.Sheets("a")
lastrow = sht.Range("A" & Rows.Count).End(xlUp).Row
strSearch = txtSearch.Text
Set aCell = sht.Range("A1:A" & lastrow).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
GoTo wfrefvalid
Else
MsgBox "Oops! That Work File does not exist. Please try again.", Title:="Try again"
txtSearch.Value = ""
End If
Exit Sub
wfrefvalid:
row_number = 0
'clears the listbox so that you have dont have a continuously growing list
lstSearch.Clear
Do
DoEvents
row_number = row_number + 1
ReDim Preserve Arr(item_in_review + 1)
item_in_review = sht.Range("A" & row_number)
If item_in_review = txtSearch.Text Then
Arr = item_in_review.Range("A" & row_number & ":J" & row_number)
End If
Loop Until item_in_review = ""
lstSearch.List = Arr
End Sub
The code isn't giving any debugging-errors, however it's also not doing anything when I press the search button. I think the area where I'm struggling is defining the array, and adding each entry to it as the find-function loops through the table (ie the last 12 or so pieces of code).
ANyone have any tips for adding the data from the search (including the extra columns) to the array?
I think the code would to be like this.
Private Sub cmdFind_Click()
Dim sht As Worksheet
Dim lastrow As Variant
Dim strSearch As String
Dim aCell As Range
Dim row_number As Integer
Dim item_in_review As Variant
Dim y As Integer
Dim Arr() As Variant
Dim rngDB As Range
Dim strAddress As String, n As Long
y = lstSearch.ListCount
Set sht = ActiveWorkbook.Sheets("a")
lastrow = sht.Range("A" & Rows.Count).End(xlUp).Row
Set rngDB = sht.Range("a1", "a" & lastrrow)
strSearch = txtSearch.Text
With rngDB
Set aCell = .Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
strAddress = aCell.Address
Do
n = n + 1
ReDim Preserve Arr(1 To 10, 1 To n)
For i = 1 To 10
Arr(i, n) = aCell(1, i)
Next i
Set aCell = .FindNext(aCell)
Loop While strAddress <> aCell.Address
Else
MsgBox "Oops! That Work File does not exist. Please try again.", Title:="Try again"
txtSearch.Value = ""
End If
End With
If n = 1 Then
lstSearch.List = Arr
ElseIf n > 1 Then
lstSearch.List = WorksheetFunction.Transpose(Arr)
End If
End Sub

How do I increment my array counter to move to the next element in the array in this code?

I have the routine below where I'm copying all the contents of a sheet if the sheet name matches the array name.
I've got the sheets copying to the destination, but I'm not getting the array value curRow to increment.
What am I missing here?
Sub test()
Dim curRow As Integer, CurrentRow As Integer, LastRow As Integer, LastRow2 As Integer
Dim activeWorksheet As Worksheet
Set activeWorksheet = ActiveSheet
Dim ws As Worksheet
Dim arArray As Variant
Sheets("Total Tabs").Activate
arArray = Sheets("Total Tabs").Range("A1", Range("A" & Rows.Count).End(xlUp))
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
curRow = 1
CurrentRow = 2
For curRow = 1 To LastRow
For Each ws In ActiveWorkbook.Worksheets
' If curRow <> 1 Then
' curRow = curRow + 1
' End If
If ws.name = arArray(curRow, 1) Then
LastRow2 = ws.Range("A" & Rows.Count).End(xlUp).Row + 1
For CurrentRow = 2 To LastRow2
ws.Range("A" & CurrentRow & ":N" & CurrentRow).Copy Destination:=Sheets("Reps No Longer Here").Range("A" & CurrentRow)
CurrentRow = CurrentRow + 1
Next
curRow = curRow + 1
End If
Next ws
Next curRow
End Sub
UPDATE:
Here is the final code that I have and works as it should. Included is also the ability to hide the tab once it has been processed.
I'm sure it can be optimized, but here it is:
Sub CombineDataToRNLH()
Dim curRow As Integer, CurrentRow As Integer, LastRow As Integer, LastRow2 As Integer
Dim activeWorksheet As Worksheet
Set activeWorksheet = ActiveSheet
Dim ws As Worksheet
Dim arArray As Variant
Dim pasterow As Integer
Dim RepName As String
'Activate the sheet with the list and then read the list of names
'straight into an array
Sheets("Total Tabs").Activate
arArray = Sheets("Total Tabs").Range("A1", Range("A" & Rows.Count).End(xlUp))
'Find last element in the array and calculate as rows
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
curRow = 1 'Index for evaluating array elements
CurrentRow = 2 'Counter for use in processing all rows in matched sheet to destination sheet
LastRow2 = 1 'Find number of rows in the matched tab
pasterow = 2 'Counter to ensure that I'm always copying data to the first available row
'Set up loop so that I can match array elements to individual sheet names
For curRow = 1 To LastRow
For Each ws In ActiveWorkbook.Worksheets
If ws.name = arArray(curRow, 1) Then
LastRow2 = ws.Range("A" & Rows.Count).End(xlUp).Row
For CurrentRow = 2 To LastRow2
ws.Range("A" & CurrentRow & ":N" & CurrentRow).Copy _
Destination:=Sheets("Reps No Longer Here").Range("A" & pasterow)
If CurrentRow = LastRow2 Then
curRow = curRow + 1
pasterow = pasterow + 1
ws.Visible = xlSheetVeryHidden 'Set it to very hidden.
Exit For
End If
pasterow = pasterow + 1
Next
End If
Next ws
Next curRow
Sheets("How To").Activate
End Sub
I think your code can be simplified and streamlined a bit. From what I gather, you want to loop through some sheets (as defined in your aaArray variable) and copy the data to a "Reps No Longer Here" tab. See if this does what you're after:
Sub test()
Dim LastRow As Long, _
LastRow2 As Long
Dim ws As Worksheet
Dim arArray As Variant
Dim sheetName As Variant
With Application
.ScreenUpdating = False
End With
With Sheets("Total Tabs")
arArray = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
For Each sheetName In arArray
On Error Resume Next
Set ws = Sheets(sheetName)
On Error GoTo 0
If ws Is Nothing Then
' we don't need to do anything since the sheet doesn't exist
Else
LastRow2 = ws.Range("A" & Rows.Count).End(xlUp).Row
LastRow = Sheets("Reps No Longer Here").Range("A" & Rows.Count).End(xlUp).Row + 1
ws.Range("A2:N" & LastRow2).Copy Destination:=Sheets("Reps No Longer Here").Range("A" & LastRow)
End If
Next sheetName
End With
With Application
.ScreenUpdating = True
End With
End Sub

Resources