Speed up For Loop by using an Array - arrays

I'm looking to speed up a For Loop (as per code below) by incorporating the use of an Array.
Would really appreciate some advice on how to do this:
Sub DetectedCheck()
'counts rows in sheet 1 and 2.
With Sheets(1)
reconrows = .Range("a" & .Rows.Count).End(xlUp).Row
End With
'Checks that the new data has both an assigned and detected role and adds "No Issue" to column Q if valid.
For i = 2 To reconrows
If ActiveWorkbook.Sheets(1).Range("J" & i).Value <> "Not Found" And ActiveWorkbook.Sheets(1).Range("K" & i).Value <> "" Then
ActiveWorkbook.Sheets(1).Range("S" & i).Value = "No Issue"
End If
Next i
End Sub

Please, try the next way:
Sub DetectedCheck()
Dim sh As Worksheet, reconRows As Long, arrJK, arrS, i As Long
Set sh = Sheets(1)
reconRows = sh.Range("a" & sh.rows.count).End(xlUp).row
arrJK = sh.Range("J2:K" & reconRows).value
arrS = sh.Range("S2:S" & reconRows).value
'Checks that the new data has both an assigned and detected role and adds "No Issue" to column Q if valid.
For i = 1 To UBound(arrJK)
If arrJK(i, 1) <> "Not Found" And arrJK(i, 2) <> "" Then
arrS(i, 1) = "No Issue"
End If
Next i
sh.Range("S2").Resize(UBound(arrS), 1).value = arrS
End Sub
But in the code comment you mention "No Issue" to column Q" and in your code you use S:S column. Please, adapt if the return must be done in Q:Q.

Want to test this method and see the speed of looping with arrays compared to rows?
Dim timmy, i As Long, rc As Long, arr1, arr2, arr3
timmy = Timer
With Sheets(1)
rc = .Range("A" & Rows.Count).End(xlUp).Row
arr1 = .Range("J2:J" & rc).Value
arr2 = .Range("K2:K" & rc).Value
ReDim arr3(1 To UBound(arr1), 1 To 1)
For i = 1 To UBound(arr1, 1)
If arr1(i, 1) = "Not Found" And IsEmpty(arr2(i, 1)) Then
arr3(i, 1) = ""
Else
arr3(i, 1) = "No Issue"
End If
Next i
.Range("S2:S" & rc).Value = arr3
End With
Debug.Print "Loopy", Timer - timmy

Loop Through Arrays Instead of Ranges
To speed up a loop, you can turn off the three most common 'speed-related' application settings: ScreenUpdating, Calculation, and EnableEvents. Often it doesn't help much.
The trick is to access the worksheet as few times as possible i.e. to write the values of the ranges to arrays (you could think of these 2D one-based arrays as ranges (in this case column ranges) in memory, starting in row 1, since they are handled similarly), loop over the arrays and write the results to another (resulting) array and write the values from the latter array to the resulting range.
The first code, the array code, took roughly 0.3 seconds for 100.000 rows of simple sample data (created with the PopulateRandomData procedure) resulting in about 25.000 No Issue cells.
For the same data, the second code, the range code, took roughly 2.5 seconds when the resulting (destination) column range was cleared previously. It took about 5 seconds if each cell was cleared in the loop (a mistake). It took 40 seconds if vbNullString or Empty were written in the loop (a huge mistake).
So the array code was roughly 8 times faster but depending on your data and how the code was previously written, the array code could be many more (tens or even hundreds of) times faster.
Note that the running times will be different for your data so your feedback is appreciated.
Check out these Excel Macro Mastery videos to quickly learn about arrays and their use to speed up code.
Option Explicit
Sub DetectedCheckArray()
' Constants
Const wsID As Variant = 1 ' safer is to use the (tab) name, e.g. "Sheet1"
Const fRow As Long = 2
Const lrCol As String = "A" ' Last Row Column
Const c1Col As String = "J" ' 1st Criteria Column
Const c2Col As String = "K" ' 2nd Criteria Column
Const NotCrit1 As String = "Not Found" ' 1st Criteria
Const NotCrit2 As String = "" ' 2nd Criteria
Const dCol As String = "S" ' Destination Column
Const dString As String = "No Issue"
' If you use constants at the beginning of the code,
' you can easily change their values in one place without
' searching in the code.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws') (in the workbook).
Dim ws As Worksheet: Set ws = wb.Worksheets(wsID) '
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
' Calculate the number of rows ('rCount').
Dim rCount As Long: rCount = lRow - fRow + 1
' Note that all ranges and arrays have this number of rows ('rCount').
' Validate the number of rows.
If rCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Reference the last row (one-column) range ('lrrg') to be used
' to easily reference the remaining ranges.
Dim lrrg As Range
' This may be more understandable (commonly used),...
Set lrrg = ws.Range(ws.Cells(fRow, lrCol), ws.Cells(lRow, lrCol))
' ... but I prefer:
'Set lrrg = ws.Cells(fRow, lrCol).Resize(rCount)
' Reference the criteria (one-column) ranges ('crg1' and 'crg2').
Dim crg1 As Range: Set crg1 = lrrg.EntireRow.Columns(c1Col)
Dim crg2 As Range: Set crg2 = lrrg.EntireRow.Columns(c2Col)
' If you have a reference to a one-column range ('lrrg') and you want
' to reference the same range in another worksheet column ('c1Col, c2Col'),
' use '.EntireRow' to easily do it, to not complicate with '.Offset'.
' The code so far runs in split seconds.
' The following is the improvement.
' Start measuring the time passed.
Dim dt As Double: dt = Timer
' Write the values from the criteria ranges
' to 2D one-based one-column arrays ('cData1' and 'cData2').
Dim cData1() As Variant
Dim cData2() As Variant
If rCount = 1 Then ' one cell
ReDim cData1(1 To 1, 1 To 1): cData1(1, 1) = crg1.Value
ReDim cData2(1 To 1, 1 To 1): cData1(1, 1) = crg2.Value
Else ' multiple cells
cData1 = crg1.Value
cData2 = crg2.Value
End If
' Define the destination string array ('dsData').
Dim dsData() As String: ReDim dsData(1 To rCount, 1 To 1)
Dim r As Long
' Loop through the rows ('r') of the arrays and for each row
' check the values of the criteria arrays against the (not) criterias.
' If all (both) conditions are met, write the destination string ('dString')
' to the current row of the destination string array.
For r = 1 To rCount
If StrComp(CStr(cData1(r, 1)), NotCrit1, vbTextCompare) <> 0 Then
If StrComp(CStr(cData2(r, 1)), NotCrit2, vbTextCompare) <> 0 Then
dsData(r, 1) = dString
End If
End If
Next r
' Reference the destination (one-column) range ('drg').
Dim drg As Range: Set drg = lrrg.EntireRow.Columns(dCol)
' Write the values from the destination string array
' to the destination range.
drg.Value = dsData
' Inform.
MsgBox "Finished in " & Timer - dt & " seconds.", vbInformation
End Sub
Sub DetectedCheckRange()
' Constants
Const wsID As Variant = 1 ' safer is to use the (tab) name, e.g. "Sheet1"
Const fRow As Long = 2
Const lrCol As String = "A" ' Last Row Column
Const c1Col As String = "J" ' 1st Criteria Column
Const c2Col As String = "K" ' 2nd Criteria Column
Const NotCrit1 As String = "Not Found" ' 1st Criteria
Const NotCrit2 As String = "" ' 2nd Criteria
Const dCol As String = "S" ' Destination Column
Const dString As String = "No Issue"
' If you use constants at the beginning of the code,
' you can easily change their values in one place without
' searching in the code.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws') (in the workbook).
Dim ws As Worksheet: Set ws = wb.Worksheets(wsID) '
' Calculate the last row ('lRow'),
' the row of the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, lrCol).End(xlUp).Row
' Calculate the number of rows ('rCount').
Dim rCount As Long: rCount = lRow - fRow + 1
' Note that all ranges and arrays have this number of rows ('rCount').
' Validate the number of rows.
If rCount < 1 Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Reference the last row (one-column) range ('lrrg') to be used
' to easily reference the remaining ranges.
Dim lrrg As Range
' This may be more understandable (commonly used),...
Set lrrg = ws.Range(ws.Cells(fRow, lrCol), ws.Cells(lRow, lrCol))
' ... but I prefer:
'Set lrrg = ws.Cells(fRow, lrCol).Resize(rCount)
' Reference the criteria (one-column) ranges ('crg1' and 'crg2').
Dim crg1 As Range: Set crg1 = lrrg.EntireRow.Columns(c1Col)
Dim crg2 As Range: Set crg2 = lrrg.EntireRow.Columns(c2Col)
' If you have a reference to a one-column range ('lrrg') and you want
' to reference the same range in another worksheet column ('c1Col, c2Col'),
' use '.EntireRow' to easily do it, to not complicate with '.Offset'.
' Reference the destination (one-column) range ('drg').
Dim drg As Range: Set drg = lrrg.EntireRow.Columns(dCol)
' The code so far runs in split seconds.
' The following loop is what is slowing down the code.
' Start measuring the time passed.
Dim dt As Double: dt = Timer
' Turn off application settings to speed up.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
drg.ClearContents ' or drg.clear (2.5 seconds)
Dim r As Long
' Loop through the rows ('r') of the column ranges and for each row
' check the values of the criteria ranges against the (not) criterias.
' If all (both) conditions are met, write the destination string ('dString')
' to the current row of the destination column.
For r = 1 To rCount
If StrComp(CStr(crg1.Cells(r).Value), NotCrit1, vbTextCompare) <> 0 Then
If StrComp(CStr(crg2.Cells(r).Value), NotCrit2, vbTextCompare) _
<> 0 Then
drg.Cells(r).Value = dString
Else ' The following line may or may not be necessary.
' Mistake, clear the complete range before (5 seconds).
'drg.Cells(r).Clear ' Contents ' or drg.Cells(r).Clear
' Huge mistake, use clear instead (40 seconds).
'drg.Cells(r).Value = Empty
'drg.Cells(r).Value = vbNullString
End If
End If
Next r
' Turn on application settings.
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
' Inform.
MsgBox "Finished in " & Timer - dt & " seconds.", vbInformation
End Sub
Sub PopulateRandomData()
Const rCount As Long = 100000
With ThisWorkbook.Worksheets(1)
.UsedRange.Clear
.Range("C:H,M:Q").EntireColumn.Hidden = True
With .Range("A2").Resize(rCount)
.Cells(1).Offset(-1).Value = "LrCol"
.Value = .Worksheet.Evaluate("ROW(1:" & CStr(rCount + 1) & ")")
.EntireColumn.AutoFit
End With
With .Range("J2").Resize(rCount)
.Cells(1).Offset(-1).Value = "Criteria1"
.Formula = "=CHOOSE(RANDBETWEEN(1,2),""Found"",""Not Found"")"
.Value = .Value
.EntireColumn.AutoFit
End With
With .Range("K2").Resize(rCount)
.Cells(1).Offset(-1).Value = "Criteria2"
.Formula = "=CHOOSE(RANDBETWEEN(1,2),""String"","""")"
.Value = .Value
.EntireColumn.AutoFit
End With
With .Range("S1")
.Value = "Result No Issue"
.EntireColumn.AutoFit
End With
End With
End Sub

Related

error 1004 unable to get the unique property of the worksheetfunction class

I have written a script to insert a range of cells into a list box of the userform in 3 steps:
The main table (A2:N...) gets filtered to a specific value in column A.
The values in column G get put into a range, then a sorted array with unique values.
The array is inputed in the listbox
I am getting the error 1004 regarding the "unique" function on rang1. I don't understand what is the issue.
Can someone kindly help me?
Private Sub UserForm_Initialize()
Dim rang, rang1, As Range
Dim lstrow, x As Long
Dim ListUniq(), ListNoEmpty(), As Variant
Dim i As Integer
Dim wb As Workbook
Dim ws As Worksheet
Dim lr As Integer
Set wb = ThisWorkbook
Set ws = wb.ActiveSheet
Set rang = ws.Range("B3").CurrentRegion
lstrow = rang.Rows.Count + 1
'Step1.The main table (A2:N...) get's filtered to a specific (Dental) value on column A.
ws.Range("$A$2:$N$" & lstrow).AutoFilter _
Field:=1, _
Criteria1:="Dental", _
Operator:=xlFilterValues
lr = Range("A" & Rows.Count).End(xlUp).Row
'Step2.The values in column G get put into a range, then a sorted array with unique values.
Set rang1 = Range("G2:G" & lr).SpecialCells(xlCellTypeVisible)
ReDim ListUniq(WorksheetFunction.CountA(rang2))
ListUniq = WorksheetFunction.Unique(rang1)
ListUniq = WorksheetFunction.sort(ListUniq)
'Resize Array prior to loading data
ReDim ListNoEmpty(WorksheetFunction.CountA(ListUniq))
'Step3.The array is inputed in the listbox
'Loop through each cell in Range and store value in Array
x = 0
For Each cell In ListUniq
If cell <> "" Then
ListNoEmpty(x) = cell
x = x + 1
End If
Next cell
ProviderListBx.list = ListNoEmpty
End Sub
Unique Values to Listbox
This will work for any version of Excel i.e. it doesn't use the Unique and Sort functions but it uses a dictionary and an ascending integer sequence in a helper column instead.
Option Explicit
Private Sub UserForm_Initialize()
PopulateProviderListBox
End Sub
Sub PopulateProviderListBox()
Const ProcName As String = "PopulateProviderListBox"
On Error GoTo ClearError
Application.ScreenUpdating = False
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1") ' adjust!
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the range ('rg').
Dim fCell As Range: Set fCell = ws.Range("A2")
Dim rg As Range
With fCell.CurrentRegion
Set rg = fCell.Resize(.Row + .Rows.Count - fCell.Row, _
.Column + .Columns.Count - fCell.Column)
End With
' Expand the range by one column and reference it ('nrg').
Dim cCount As Long: cCount = rg.Columns.Count + 1
Dim nrg As Range: Set nrg = rg.Resize(, cCount)
' Write an ascending integer sequence to the (new) helper column.
Dim rCount As Long: rCount = rg.Rows.Count
nrg.Columns(cCount).Value = ws.Evaluate("=ROW(1:" & rCount & ")")
' Sort the new range by the lookup column ('7').
nrg.Sort nrg.Columns(7), xlAscending, , , , , , xlYes
' Reference the data (no headers) of the lookup column ('lrg').
Dim lrg As Range: Set lrg = nrg.Columns(7).Resize(rCount - 1).Offset(1)
' Filter the new range by the criteria in the criteria column ('1').
nrg.AutoFilter 1, "Dental"
' Attempt to reference all visible cells ('vrg') of the lookup column.
Dim vrg As Range
On Error Resume Next
Set vrg = lrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Turn off the autofilter.
ws.AutoFilterMode = False
If Not vrg Is Nothing Then
' Return the unique (sorted) values
' in the keys of a dictionary ('dict').
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim vCell As Range
For Each vCell In vrg.Cells
dict(vCell.Value) = Empty
Next vCell
' Return the unique (sorted) values in the listbox.
If dict.Count > 0 Then ProviderListBx.List = dict.Keys
End If
' Sort the new range by the helper column to regain initial order.
nrg.Sort nrg.Columns(cCount), xlAscending, , , , , , xlYes
' Clear the helper column.
nrg.Columns(cCount).Clear
Application.ScreenUpdating = True
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
Even if you Excel version accepts UNIQUE and Sort formulas and then WorksheetFunction methods, both of them do not behave exactly as Excel respective formulas...
WorksheetFunction.UNIQUE does not work on discontinuous ranges.
The next line, returns such a range:
Set rang1 = Range("G2:G" & lr).SpecialCells(xlCellTypeVisible)
Even ListUniq = WorksheetFunction.sort(rang1) does not work because of the above mentioned behavior. If ListUniq would be a continuous range it will work.
Then, declaring Dim ListUniq() makes useless the line ReDim ListUniq(WorksheetFunction.CountA(rang2)), which anyhow uses an non existing range. Probably, it is a type and it should be rang1, but still useless. VBA is able to return the array without needing a previous ReDim. Only the range to be continuous.
In such cases, a function transforming the discontinuous range in a continuous array would solve your issue:
Private Function ListUniqFromDiscR_2D(rng As Range) As Variant 'makes 2D (one column) array from a discontinuous range
Dim A As Range, ListUniq, count As Long, i As Long
ReDim ListUniq(1 To rng.cells.count, 1 To 1): count = 1
For Each A In rng.Areas
For i = 1 To A.cells.count
ListUniq(count, 1) = A.cells(i).Value: count = count + 1
Next
Next
ListUniqFromDiscR_2D = ListUniq
End Function
It can be used in your code as:
Set rang1 = Range("G2:G" & lr).SpecialCells(xlCellTypeVisible)
ListUniq = ListUniqFromDiscR_2D(rang1) 'the continuous extracted array
Debug.Print Join(Application.Transpose(ListUniq), "|") 'just to visually see the (continuous) returned array
ListUniq = WorksheetFunction.unique(ListUniq) 'the unique elements array
ListUniq = WorksheetFunction.Sort(ListUniq) 'the unique sorted array
Debug.Print Join(Application.Transpose(ListUniq), "|") 'just to the unique, sorted array (in Immediate Window)...
But if your Excel version is not able to handle Unique and Sort, there are not standard VBA functions doing it very fast. If this is your case, I can also post such functions.

Using Find with data split into multiple 2D arrays

I have a report to update from data in another report. Both reports are large, over 50,000 rows. I read them into arrays so the process runs faster.
I need to split the Source array into separate arrays based on certain conditions in the HR array. I get an object required error when I try to assign a value to the ID variable.
Option Explicit
Sub SearchArrays()
Dim wb As Workbook, wsSource As Worksheet, wsHR As Worksheet
Dim arrSource() As Variant, arrHR() As Variant, arrNotFound() As Variant, arrRemoved() As Variant, arrUpdated() As Variant
'Dim ID As String
Dim ID As Variant
Dim x As Long, y As Long, nCounter As Long, CounterN As Long, rCounter As Long, CounterR As Long, uCounter As Long, CounterU As Long
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Source")
Set wsHR = wb.Worksheets("HR")
wsSource.Activate
arrSource = Range("A2", Range("A2").End(xlDown).End(xlToRight)) 'Read Source data into array
wsHR.Activate
arrHR = Range("A2", Range("A2").End(xlDown).End(xlToRight)) 'Read HR data into array
'Use Find to find the values in source array in the hr array
For x = LBound(arrSource, 1) To UBound(arrSource, 1)
For y = LBound(arrHR, 1) To UBound(arrHR, 1)
'ID is in column 2 of Source data and column 3 of HR data
Set ID = arrSource(x, 2).Find(what:=arrHR(y, 3).Value, LookIn:=xlValues, lookat:=xlWhole)
If ID Is Nothing Then
'Copy data to Not Found array
nCounter = nCounter + 1
ReDim Preserve arrNotFound(1 To 5, 1 To nCounter) 'Redimension the Not Found array with each instance
For CounterN = 1 To 5 'The arrNotFound equals the current row
arrNotFound(CounterN, nCounter) = arrSource(x, CounterN)
Next CounterN
ElseIf Not ID Is Nothing And ID.Offset(, 3).Value <> arrHR(y, 3).Offset(, 2) Then
'Copy to removed array
rCounter = rCounter + 1
ReDim Preserve arrRemoved(1 To 5, 1 To rCounter) 'Redimension the Removed array with each instance
For CounterR = 1 To 5 'The arrRemoved equals the current row
arrRemoved(CounterR, rCounter) = arrSource(x, CounterR)
Next CounterR
ElseIf Not ID Is Nothing And ID.Offset(, 3).Value = arrHR(y, 3).Offset(, 2) Then
'Copy to Updated array
uCounter = uCounter + 1
ReDim Preserve arrUpdated(1 To 5, 1 To uCounter) 'Redimension the Updated array with each instance
For CounterU = 1 To 5 'The arrUpdated equals the current row
arrUpdated(CounterU, uCounter) = arrSource(x, CounterU)
Next CounterU
End If
Next y
Next x
'Write arrNotFound to a new worksheet
'Write arrRemoved to a new worksheet
'Write arrUpdated to a new worksheet
End Sub
Sample Data:
Split Data Into Arrays
In a Nutshell
It writes the lookup data to a dictionary (lDict).
It writes the source data to a 2D one-based array (sData).
It writes the source data rows (srData) to three collections in an array (dcData).
It writes the data to up to three 2D one-based arrays in another array (dData). This jagged array holds the 'three' required arrays.
It writes the data to up to three new worksheets.
The Code
Option Explicit
Sub SplitDataIntoArrays()
' Define constants.
' Lookup
Const lName As String = "HR"
Const lCol1 As Long = 3
Const lCol2 As Long = 6
' Source
Const sName As String = "Source"
Const sCol1 As Long = 2
Const sCol2 As Long = 5
' Destination
Dim dNames() As Variant
dNames = VBA.Array("Updated", "Removed", "Not Found")
Const dfCellAddress As String = "A1"
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the values from the lookup worksheet columns
' to two 2D one-based one-column arrays ('lData1', 'lData2').
Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
Dim lrg As Range: Set lrg = lws.Range("A1").CurrentRegion
Dim lrCount As Long: lrCount = lrg.Rows.Count
If lrCount = 1 Then
MsgBox "No data in the lookup worksheet.", vbCritical
Exit Sub
End If
Dim lData1() As Variant: lData1 = lws.Columns(lCol1).Value
Dim lData2() As Variant: lData2 = lws.Columns(lCol2).Value
' Write the unique values from the lookup arrays
' to the lookup dictionary ('lDict') whose keys will hold
' the value from the first array while its items will hold
' the corresponding values from the second array.
Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
lDict.CompareMode = vbTextCompare
Dim r As Long
Dim lString As String
For r = 2 To lrCount
lString = CStr(lData1(r, 1))
If Len(lString) > 0 Then ' exclude blanks
If Not lDict.Exists(lString) Then
lDict(lString) = CStr(lData2(r, 1))
'Else ' already exists; there shouldn't be duplicates!
End If
End If
Next r
If lDict.Count = 0 Then
MsgBox "No valid data in the lookup column range.", vbCritical
Exit Sub
End If
' Free memory since the lookup data is in the lookup dictionary.
Erase lData1
Erase lData2
' Write the data from the source worksheet
' to a 2D one-based array ('sData').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
If srCount = 1 Then
MsgBox "No data in the source worksheet.", vbCritical
Exit Sub
End If
Dim scCount As Long: scCount = srg.Columns.Count
Dim sData() As Variant: sData = srg.Value
' Using the information in the lookup dictionary, write the values
' from the source array to the (jagged) destination collection array
' ('dcData') whose each element will hold a collection
' of the appropriate 1D source row arrays ('srData').
Dim srData() As String: ReDim srData(1 To scCount)
Dim dcData() As Variant: ReDim dcData(1 To 3)
Dim dc As Long
' Add a new collection to each element of the destination collection array.
For dc = 1 To 3
Set dcData(dc) = New Collection
Next dc
Dim sString1 As String
Dim sString2 As String
Dim sCase As Long
Dim sc As Long
' Add the row arrays to the collections.
For r = 2 To srCount
sString1 = CStr(sData(r, sCol1))
If lDict.Exists(sString1) Then
sString2 = CStr(sData(r, sCol2))
If StrComp(sString2, lDict(sString1), vbTextCompare) = 0 Then
sCase = 1 ' updated
Else
sCase = 2 ' removed
End If
Else
sCase = 3 ' not found
End If
For sc = 1 To scCount
srData(sc) = sData(r, sc)
Next sc
dcData(sCase).Add srData
Next r
' Write the data from the destination collection array
' to the destination (jagged) array ('dData') which will hold up to three
' 2D one-based arrays (ready to be easily written to the worksheets).
Dim dData() As Variant: ReDim dData(1 To 3)
Dim cData() As Variant ' each 2D one-based array in the destination array
Dim drCount As Long
Dim dItem As Variant
For dc = 1 To 3
drCount = dcData(dc).Count ' number of source row ranges...
' ... or the number of current destination array data rows
If drCount > 0 Then
drCount = drCount + 1 ' include headers
ReDim cData(1 To drCount, 1 To scCount)
' Write headers
For sc = 1 To scCount
cData(1, sc) = sData(1, sc)
Next sc
' Write data.
r = 1 ' headers are written
For Each dItem In dcData(dc)
r = r + 1
For sc = 1 To scCount
cData(r, sc) = dItem(sc)
Next sc
Next dItem
dData(dc) = cData ' assign current array to the destination array
End If
Next dc
' Free memory since the data is in the destination array.
Set lDict = Nothing
Erase sData
Erase dcData
Erase cData
' Write the data from the destination array to the destination worksheets.
Application.ScreenUpdating = False
Dim dws As Worksheet ' Current Destination Worksheet
Dim drg As Range ' Current Destination Range
For dc = 1 To 3
' Delete the worksheet if it exists.
On Error Resume Next
Set dws = wb.Worksheets(dNames(dc - 1))
On Error GoTo 0
If Not dws Is Nothing Then ' the worksheet exists; delete it
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
'Else ' the worksheet doesn't exist; do nothing
End If
If Not IsEmpty(dData(dc)) Then ' appropriate array is not empty; write
' Add a new worksheet after all sheets.
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
' Rename the newly added worksheet.
dws.Name = dNames(dc - 1)
' Reference the destination range.
Set drg = dws.Range(dfCellAddress) _
.Resize(UBound(dData(dc), 1), scCount)
' Write the values from the destination array
' to the destination range.
drg.Value = dData(dc)
' Apply some formatting.
drg.Rows(1).Font.Bold = True
drg.EntireColumn.AutoFit
' Reset the variable to be ready for the next check.
Set dws = Nothing
'Else ' appropriate array is empty; do nothing
End If
Next dc
' Save the workbook.
'wb.Save
Application.ScreenUpdating = True
MsgBox "Data split.", vbInformation
End Sub

VBA 2D Array for each item find average value

I am trying to find a way to average an array column value with a condition on items from another column in that array - I am aware that a class or dictionary might be the best solution but I would like to stick to an array as in my real scenario I have to use an array.
In this case the data is as follows
Risk ID Data set 1 Data set 2
23359720 1154 587
23359720 1254 658
23359720 854 756
23293773 965 1456
20053692 1458 458
I would like to find the average of Data sets 1 and 2 per Risk ID, here is what I've tried but does not work - I have seen that this it's not possible to use for each and point it to a specific column, but not sure what else to do in the case of an array?
Edit: expected result data:
ArrayResultAverage()
Risk ID Avg Data set 1 Avg Data set 2
23359720 1087.33 667
23293773 965 1456
20053692 1458 458
Sub Test_Arr_Avg()
'
Dim TESTWB As Workbook
Dim TESTWS As Worksheet
Set TESTWB = ThisWorkbook
Set TESTWS = TESTWB.Worksheets("TEST")
'Array set up
Dim RngTest As Range
Dim ArrTestAvg As Variant
NbRowsTest = TESTWS.Range("A1").End(xlDown).Row
Set RngTest = TESTWS.Range(TESTWS.Cells(1, 1), TESTWS.Cells(NbRowsTest, 3))
ArrTestAvg = RangeToArray2D(RngTest)
'Find the average of Data Range 1 for each item in Risk ID
For k = 1 To UBound(ArrTestAvg, 1)
Dim Sum As Variant
Sum = 0
For Each Item In ArrTestAvg(k, 1)
Sum = Sum + ArrTestAvg(k, 2)
Dim AverageDataSet1 As Variant
AverageDataSet1 = Sum / UBound(ArrTestAvg(Item)) + 1
Debug.Print AverageDataSet1
Next Item
Next k
End Sub
Public Function RangeToArray2D(inputRange As Range) As Variant()
Dim size As Integer
Dim inputValue As Variant, outputArray() As Variant
inputValue = inputRange
On Error Resume Next
size = UBound(inputValue)
If Err.Number = 0 Then
RangeToArray2D = inputValue
Else
On Error GoTo 0
ReDim outputArray(1 To 1, 1 To 1)
outputArray(1, 1) = inputValue
RangeToArray2D = outputArray
End If
On Error GoTo 0
End Function
Get Averages of Unique Data
Adjust the values in the constants section, especially the destination worksheet name (it's the same as the source worksheet name) and its first cell address.
The dictionary's keys hold the unique risk ids, while its items (values) hold the associated destination rows.
The result is written to the same array (which is too big) but with dr the destination row size is tracked and only three columns will be copied.
Before the calculation of the averages, column 1 holds the unique risk ids (the same order as in the dictionary), columns 2 and 3 hold the sums while columns 4 and 5 hold the counts of the first and second data set respectively.
Option Explicit
Sub Test_Arr_Avg()
' Source
Const sName As String = "Sheet1"
' Destination
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "E1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Read from source.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg As Range: Set srg = sws.Range("A1", sws.Cells(slRow, "C"))
Dim srCount As Long: srCount = srg.Rows.Count
' Write source range values to array.
Dim Data As Variant: Data = GetRange(srg)
' Add two helper columns for the count.
ReDim Preserve Data(1 To srCount, 1 To 5)
' Sum up and count uniques.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim dr As Long: dr = 1 ' first row are headers
Dim sr As Long
Dim cr As Long
Dim c As Long
For sr = 2 To srCount
' Sum up.
If dict.Exists(Data(sr, 1)) Then
cr = dict(Data(sr, 1))
For c = 2 To 3
Data(cr, c) = Data(cr, c) + Data(sr, c)
Next c
Else
dr = dr + 1
cr = dr
dict(Data(sr, 1)) = cr
For c = 1 To 3
Data(cr, c) = Data(sr, c)
Next c
End If
' Count.
For c = 4 To 5
Data(cr, c) = Data(cr, c) + 1
Next c
Next sr
' Calculate averages.
For cr = 2 To dr
For c = 2 To 3
Data(cr, c) = Data(cr, c) / Data(cr, c + 2)
' You might want to round the results instead:
'Data(cr, c) = Round(Data(cr, c) / Data(cr, c + 2), 2)
Next c
Next cr
Application.ScreenUpdating = False
' Write to destination.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress).Resize(, 3)
.Resize(dr).Value = Data
' Clear below.
.Resize(dws.Rows.Count - .Row - dr + 1).Offset(dr).Clear
' Apply various formatting.
.Font.Bold = True ' headers
.Resize(dr - 1, 2).Offset(1, 1).NumberFormat = "#0.00" ' averages
.EntireColumn.AutoFit ' columns
End With
'wb.Save
' Inform.
Application.ScreenUpdating = True
MsgBox "Risk ids averaged.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
It would be complicated to use a single Dictionary. Here I add a Sub-Dictionary for each Risk ID to the main Dictionary. The Sub-Dictionary is used to hold all the values for each ID. The final step is to create an array of averages for all the main Dictionary items.
Sub Test_Arr_Avg()
Dim Data As Variant
With TestWS.Range("A1").CurrentRegion
Data = .Offset(1).Resize(.Rows.Count - 1, 3)
End With
Dim Results As Variant
Results = KeyedAverages(Data, 1, 2)
Stop
End Sub
Function KeyedAverages(Data As Variant, IDColumn As Long, ValueColumn As Long)
Dim Map As Object
Set Map = CreateObject("Scripting.Dictionary")
Dim Key As Variant
Dim r As Long
For r = 1 To UBound(Data)
Key = CStr(Data(r, IDColumn))
If Len(Key) > 0 Then
If Not Map.Exists(Key) Then Map.Add Key, CreateObject("Scripting.Dictionary")
With Map(Key)
.Add CStr(.Count), Data(r, ValueColumn)
End With
End If
Next
Dim Results As Variant
Dim Values As Variant
ReDim Results(1 To Map.Count, 1 To 2)
Dim n As Long
For Each Key In Map.Keys
n = n + 1
Values = Map(Key).Items
Results(n, 1) = Key
Results(n, 2) = WorksheetFunction.Average(Values)
Next
KeyedAverages = Results
End Function
Public Function TestWB() As Workbook
Set TestWB = ThisWorkbook
End Function
Public Function TestWS() As Worksheet
Set TestWS = TestWB.Worksheets("Test")
End Function
Note: Code updated to exclude empty items.

VBA Copy row from one 2D array and add it to another 2D array

I have a large database (~7000 rows x 25 columns) that i have assigned to an array. Based on user inputs, I am trying to search the database to find items that match the input and copy the entire row to a new array to create a new database to filter with the next question. The arrays are DBRange and DBT and are defined as public variants. I've tried copying the data from DBRange to a new sheet, but that is incredibly slow and I'm trying to speed things up with keeping things within arrays if possible.
DBRange = wsd.Range("A1").CurrentRegion 'Sets DBRange to the entirety of the Database
Cervical = 0
If CervicalStartOB.Value = True Then
Cervical = 1
SpineSection.Hide
For i = LBound(DBRange, 1) To UBound(DBRange, 1) 'starts for loop starting with the 1st row in the array to the last row
If DBRange(i, 13) = "X" Then 'determines if the value in row i column 13 has an X
ReDim Preserve DBT(count, UBound(DBRange, 2))
DBT(count, UBound(DBRange, 2)) = Application.WorksheetFunction.Index(DBRange, i, 0)
count = count + 1
End If
Next i
Get Range Criteria Rows
Option Explicit
Sub GetRangeCriteriaRowsTESTKeepHeaders()
Const sCriteriaString As String = "X"
Const sCol As Long = 13
Const sfRow As Long = 2 ' First Data Row
Dim wsd As Worksheet: Set wsd = ActiveSheet
' Reference the source range
Dim srg As Range: Set srg = wsd.Range("A1").CurrentRegion
' Write the criteria rows to an array.
' If you want to keep headers, use the first row ('sfrow')
' as the parameter of the 'FirstRow' argument of the function.
Dim DBT As Variant
DBT = GetRangeCriteriaRows(srg, sCriteriaString, sCol, sfRow)
If IsEmpty(DBT) Then Exit Sub
End Sub
Sub GetRangeCriteriaRowsTESTOnlyData()
Const sCriteriaString As String = "X"
Const sCol As Long = 13
Const sfRow As Long = 2 ' First Data Row
Dim wsd As Worksheet: Set wsd = ActiveSheet
' Reference the source range.
Dim srg As Range: Set srg = wsd.Range("A1").CurrentRegion
' Reference the data range (no headers).
Dim shrCount As Long: shrCount = sfRow - 1
Dim sdrg As Range
Set sdrg = srg.Resize(srg.Rows.Count - shrCount).Offset(shrCount)
' Write the criteria rows to an array.
' If the range has no headers, don't use the 'FirstRow' argument
' of the function.
Dim DBT As Variant: DBT = GetRangeCriteriaRows(sdrg, sCriteriaString, sCol)
If IsEmpty(DBT) Then Exit Sub
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of the rows of a range ('SourceRange'),
' that meet a string criterion ('CriteriaString') in a column
' ('CriteriaColumnIndex'), in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRangeCriteriaRows( _
ByVal SourceRange As Range, _
ByVal CriteriaString As String, _
Optional ByVal CriteriaColumnIndex As Long = 1, _
Optional ByVal FirstRow As Long = 1) _
As Variant
Const ProcName As String = "GetRangeCriteriaRows"
On Error GoTo ClearError
' Count the source rows and the source/destination columns.
Dim srCount As Long: srCount = SourceRange.Rows.Count
Dim cCount As Long: cCount = SourceRange.Columns.Count
' Count the source header rows.
Dim shrCount As Long: shrCount = FirstRow - 1
' Define the source data range according to the first row.
Dim sdrg As Range
Set sdrg = SourceRange.Resize(srCount - shrCount).Offset(shrCount)
' Write the source range values to the source array.
Dim sData As Variant: sData = SourceRange.Value
' Count the criteria rows in the source data criteria column range.
Dim sdcrg As Range: Set sdcrg = sdrg.Columns(CriteriaColumnIndex)
Dim drCount As Long
drCount = Application.CountIf(sdcrg, CriteriaString) + shrCount
' Define the destination array.
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
Dim sr As Long ' Current Source Row
Dim c As Long ' Current Source/Destination Column
Dim dr As Long ' Current Destination Row
' Write the header rows from the source array to the destination array.
If FirstRow > 1 Then
For sr = 1 To shrCount
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(sr, c)
Next c
Next sr
End If
' Write the criteria rows from the source array to the destination array.
For sr = FirstRow To srCount
If StrComp(CStr(sData(sr, CriteriaColumnIndex)), CriteriaString, _
vbTextCompare) = 0 Then
dr = dr + 1
For c = 1 To cCount
dData(dr, c) = sData(sr, c)
Next c
End If
Next sr
GetRangeCriteriaRows = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function

Performance of Excel Array and small VBA Loop vs. Big VBA Loop w/o Array

I've got two worksheets. The first (Calculation) contains 10.000 rows with a lot of RTD formulas and different calculations. The second (observer) observes the first one.
I've got a VBA script that runs every second and checks every row of worksheet 1 (Calculation). If the loop finds some marked data on worksheet 1 then it will copy some data from WS1 to WS2.
Solution 1: Loop checking 10.000 rows
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For I = 1 To 10000
If CStr(.Cells(I, 1)) = "X" Then
'DO SOME SUFF (copy the line from WS 1 to WS2)
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Solution 2: Array function with a small loop
Can I use, instead of the 10.000 row loop, an Excel Array to observe the 10.000 rows and do some stuff with the smaller array.
On worksheet 2, I would have this code: (A1:O15)
{=index(Calculation!A$1:$O$10000; .....)....))}
Again I would have a smaller loop through the 15 lines of array function:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For K = 1 To 15
If CStr(.Cells(I, 1)) = "X" Then
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I would like to know what solution has the better performance.
I am not sure if an Excel array over 10.000 rows has a good performance. For sure the 15-rowLoop is faster than a 10000-row-Loop.
I don't know how to measure if a 15-row Loop in connection with an array (observing 10.000 rows) is faster.
Copy to Sheet With Criteria
Copies each row of a dataset in a worksheet containing a specified value (Criteria) in a specified column, to another worksheet.
Adjust the values in the constants section of createReport.
The data transfer will only (always) happen when the worksheet "Observer" is activated e.g. when another sheet is currently selected and the "Observer" tab is clicked on.
This code took about 5 seconds for a million (all) rows, and under a second for 100.000 rows on my machine.
The efficiency can further be improved by using the code with the Worksheet Change event in the "Calculation" worksheet and by turning off certain Application events (e.g. .ScreenUpdating, .Calculation, .EnableEvents).
Excel Test Setup (Worksheet "Calculation")
[A1:I1] ="Column "&COLUMN()
[A2] =IF(I2=1,"X","Y")
[B2:H2] =RANDBETWEEN(1,1000)
[I2] =RANDBETWEEN(1,100)
Sheet Module (Worksheet "Observer")
Option Explicit
Private Sub Worksheet_Activate()
createReport
End Sub
Standard Module e.g. Module1
Option Explicit
Sub createReport()
' Constants
' Source
Const srcName As String = "Calculation"
Const CriteriaColumn As Long = 1
Const Criteria As String = "X"
Const srcFirstCellAddress As String = "A1"
' Target
Const tgtName As String = "Observer"
Const tgtFirstCellAddress As String = "A1"
Const includeHeaders As Boolean = True
' Other
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Range ('rng').
' Define Source First Cell ('cel').
Dim cel As Range
Set cel = wb.Worksheets(srcName).Range(srcFirstCellAddress)
' Define the Current Region ('rng') 'around' First Cell.
Dim rng As Range
Set rng = cel.CurrentRegion
' Define Source Range ('rng') i.e. exclude cells to the left and above
' of Source First Cell from the Current Region.
Set rng = rng.Resize(rng.Rows.Count - cel.Row + rng.Row, _
rng.Columns.Count - cel.Column + rng.Column) _
.Offset(cel.Row - rng.Row, cel.Column - rng.Column)
' Write values from Source Range to Data Array ('Data').
Dim Data As Variant
Data = rng.Value
' Write resulting values from Data Array to Data Array
' i.e. 'shift' them to the beginning.
Dim NoC As Long ' Number of Columns
NoC = UBound(Data, 2)
Dim i As Long ' Source Data Rows Counter
Dim j As Long ' Source/Target Data Columns Counter
Dim CurrentRow As Long ' Target Data Rows Counter
Dim checkHeaders As Long
checkHeaders = -CLng(includeHeaders) ' True is '-1' in VBA.
CurrentRow = checkHeaders
For i = 1 To UBound(Data, 1)
If Data(i, CriteriaColumn) = Criteria Then
CurrentRow = CurrentRow + 1
For j = 1 To NoC
' 'Shift' from 'i' to 'CurrentRow'.
Data(CurrentRow, j) = Data(i, j)
Next j
End If
Next i
' Write values from Data Array to Target Range ('rng').
' Define Target First Cell ('cel').
Set cel = wb.Worksheets(tgtName).Range(tgtFirstCellAddress)
' Define Target First Row ('rng').
Set rng = cel.Resize(, NoC)
' Clear contents in columns.
rng.Resize(rng.Worksheet.Rows.Count - cel.Row + 1).ClearContents
Select Case CurrentRow
Case 0
GoTo CriteriaNotFound
Case checkHeaders
' Write headers from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo CriteriaNotFound
Case Else
' Write values from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo Success
End Select
' Exit.
ProcExit:
Exit Sub
' Inform user.
CriteriaNotFound:
MsgBox "Value '" & Criteria & "' not found.", vbExclamation, "Fail"
GoTo ProcExit
Success:
MsgBox CurrentRow - checkHeaders & " row(s) of data transferred.", _
vbInformation, "Success"
GoTo ProcExit
End Sub
Rather than going back to column A 10,000 times, bring all the values into a 1D VBA array and then loop over that array:
Sub whatever()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = WorksheetFunction.Transpose(rng)
For i = 1 To 10000
If arr(i) = "X" Then
'do some stuff
End If
Next i
End Sub
If there are very few X's then it may be nearly instantaneous.
EDIT#1:
Based on Chris Neilsen's comment, here is a version that does not use Transpose():
Sub whatever2()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = rng
For i = 1 To 10000
If arr(i, 1) = "X" Then
'do some stuff
End If
Next i
End Sub
Test the next code, please. It should be very fast, using arrays and everything happening in memory. The code assumes that you need to copy all occurrences starting with the last empty cell of WS2:
Sub CopyFromWS1ToWs2Array()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, i As Long, k As Long, j As Long
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
k = k + 1 'the array row is incremented (in fact, it is the column now...)
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
End If
Next i
'the final array is Redim, preserving only the existing values:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
LR2 = WS2.cells(rows.count, 1).End(xlUp).row + 1 'last empty row of the second worksheet
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2).Select
MsgBox "Ready...", vbInformation, "Job done"
End Sub
Edited:
Please, test the next code, which should also solve your last requests (as I understood them):
Sub CopyFromWS1ToWs2ArrayBis()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, arrWS2 As Variant
Dim i As Long, k As Long, j As Long, s As Long, boolFound As Boolean
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
LR2 = WS2.cells(rows.count, 1).End(xlUp).row 'last empty row of the second worksheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range of WS1 in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
arrWS2 = WS2.Range("A1:N" & LR2).Value 'put the range of WS2 in an array
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
For s = 1 To UBound(arrWS2)
If arr1(i, 1) = arrWS2(s, 1) And arr1(i, 2) = arrWS2(s, 2) And _
arr1(i, 3) = arrWS2(s, 3) Then
boolFound = True: Exit For 'if first three array columns are the same
End If
Next s
If Not boolFound Then 'if first thrree array columns not the same:
k = k + 1 'the array row is incremented
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
'swap the columns 4 and 5 values:
If arr1(i, 4) = "ABC" And arr1(i, 5) = "XYZ" Then arr2(4, k) = "XYZ": arr2(5, k) = "ABC"
End If
boolFound = False 'reinitialize the boolean variable
End If
Next i
If k > 0 Then
'Preserving only the existing array elements:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2 + 1).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2 + 1).Select
MsgBox "Ready...", vbInformation, "Job done"
Else
MsgBox "No any row to be copied!", vbInformation, "Nothing changed"
End If
End Sub

Resources