I use the code hereunder to calculate max values as described in this post (vba max value of group of values). The code works great but once I have more than 65k lines I get a data type mismatch when trying to pase the array:
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
Could somebody help me to slice the array in chunks. I have tried to get it working myself but without any luck.
Sub FillGroupsMax()
Dim lColumn As Long
Dim sht As Worksheet
Dim groupsArray As Variant 'array with all group infomation
Dim groupsSeen As Variant 'array with group infomation already seen
Application.ScreenUpdating = False 'stop screen updating makes vba perform better
Set sht = ThisWorkbook.Worksheets("import")
Set last = sht.Range("A:A").Find("*", Cells(1, 1), searchdirection:=xlPrevious) 'last cell with value in column A
lColumn = sht.Cells(1, Columns.Count).End(xlToLeft).Column
groupsArray = sht.Range(Cells(1, 1), Cells(last.Row, lColumn))
'collect all the information on the Sheet into an array
'Improves performance by not visiting the sheet
For dRow = 2 To last.Row 'for each of the rows skipping header
'check if group as already been seen
If inArrayValue(Cells(dRow, 1).Value, groupsSeen) > 0 Then
'if it has been seen/calculated attribute value
'Cells(dRow, 4).Value = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
groupsArray(dRow, lColumn) = inArrayValue(Cells(dRow, 1).Value, groupsSeen)
Else
'if it hasn't been seen then find max
'Cells(dRow, 4).Value = getMax(Cells(dRow, 1).Value, groupsArray)
groupsArray(dRow, lColumn) = getMax(Cells(dRow, 1).Value, groupsArray, lColumn)
'array construction from empty
If IsEmpty(groupsSeen) Then
ReDim groupsSeen(0)
'groupsSeen(0) = Array(Cells(dRow, 1).Value, Cells(dRow, 4).Value)
groupsSeen(0) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
'attribute value to array
Else
ReDim Preserve groupsSeen(0 To UBound(groupsSeen) + 1)
groupsSeen(UBound(groupsSeen)) = Array(groupsArray(dRow, 1), groupsArray(dRow, lColumn))
End If
End If
Next
sht.Range(Cells(1, lColumn), Cells(last.Row, lColumn)).Value = Application.Index(groupsArray, , lColumn)
'reactivate Screen updating
Application.ScreenUpdating = True
End Sub
Function getMax(group As String, groupsArray As Variant, lColumn As Long) As Double
'for each in array
For n = 1 To UBound(groupsArray)
'if its the same group the Max we seen so far the record
If groupsArray(n, 1) = group And groupsArray(n, lColumn - 1) > maxSoFar Then
maxSoFar = groupsArray(n, lColumn - 1)
End If
Next
'set function value
getMax = maxSoFar
End Function
Function inArrayValue(group As String, groupsSeen As Variant) As Double
'set function value
inArrayValue = 0
'if array is empty then exit
If IsEmpty(groupsSeen) Then Exit Function
'for each in array
For n = 0 To UBound(groupsSeen)
'if we find the group
If groupsSeen(n)(0) = group Then
'set function value to the Max value already seen
inArrayValue = groupsSeen(n)(1)
'exit function earlier
Exit Function
End If
Next
End Function
You can write a helper function to use instead of Application.Index
Bonus - it will be much faster than using Index (>5x)
Sub Tester()
Dim arr, arrCol
arr = Range("A2:J80000").Value
arrCol = GetColumn(arr, 5) '<< get the fifth column
Range("L2").Resize(UBound(arrCol, 1), 1).Value = arrCol
End Sub
'extract a single column from a 1-based 2-D array
Function GetColumn(arr, colNumber)
Dim arrRet, i As Long
ReDim arrRet(1 To UBound(arr, 1), 1 To 1)
For i = 1 To UBound(arr, 1)
arrRet(i, 1) = arr(i, colNumber)
Next i
GetColumn = arrRet
End Function
EDIT - since QHarr asked about timing here's a basic example
Sub Tester()
Dim arr, arrCol, t, i as long
arr = Range("A2:J80000").Value
t = Timer
For i = 1 to 100
arrCol = GetColumn(arr, 5) '<< get the fifth column
Next i
Debug.print Timer - t '<<# of seconds for execution
End Sub
Below, whilst not as tidy as could be, is a way to process an array in chunks and Index to access a column and write out to the sheet.
I populated two columns (A:B) with data. Both had 132,000 rows, populated incrementally, with values from 1 to 132,000 in each column for my test run.
You can fiddle with cutOff to get the chunk size just below the point where the fail happens.
The code below is simply to demonstrate the principle of looping in batches, upto the set cutoff in each batch, until all rows have been processed.
Option Explicit
Public Sub WriteArrayToSheet()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set sht = wb.Worksheets("Sheet1") 'change as appropriate
Dim myArr() 'dynamic array
myArr = sht.Range("A1").CurrentRegion.Value 'you may want a more robust method
Dim cutOff As Long 'the max value - what ever it is before error occurs
cutOff = 1000
Dim totalRows As Long 'total rows in array read in from sheet
totalRows = UBound(myArr, 1)
Dim totalArraysNeeded As Long
'Determine how many lots of cutOff chunks there are in the total number of array rows
totalArraysNeeded = Application.WorksheetFunction.Ceiling(totalRows / cutOff, 1)
Dim rotations As Long 'number of times to loop original array to handle all rows
Dim rowCountTotal As Long
Dim rowCount As Long
Dim tempArr() 'this will hold the chunk of the original array
Dim rowCounter As Long
Dim lastRow As Long
Dim nextRow As Long
Dim i As Long
Dim j As Long
Dim numRows As Long
rotations = 1
Do While rotations < totalArraysNeeded
If rotations < totalArraysNeeded - 1 Then
ReDim tempArr(1 To cutOff, 1 To UBound(myArr, 2)) 'size chunk array
numRows = cutOff
Else
numRows = totalRows - rowCountTotal
ReDim tempArr(1 To numRows, 1 To UBound(myArr, 2)) 'size chunk array
End If
For i = 1 To numRows
rowCount = 1 'rows in this chunk looped
rowCountTotal = rowCountTotal + 1 'rows in original array looped
For j = LBound(myArr, 2) To UBound(myArr, 2)
tempArr(i, j) = myArr(rowCountTotal, j)
Next j
rowCount = rowCount + 1
Next i
With sht
lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row 'Column where I am writing the sliced column out to
End With
If lastRow = 1 Then
nextRow = 1
Else
nextRow = lastRow + 1
End If
sht.Range("E" & nextRow).Resize(UBound(tempArr, 1), 1) = Application.Index(tempArr, , 1) 'write out to sheet
rotations = rotations + 1
Loop
End Sub
As #Tim suggested, the best way to slice a large array is use a loop to copy the column.
Though in your case, most of the processing time is spent on computing the maximum since your code is using a nested loop.
If you want to reduce significantly the processing time, then use a dictionary:
Sub Usage
GetMaxByGroupTo _
sourceGroups := ThisWorkbook.Range("Sheet1!A2:A100"), _
sourceValues := ThisWorkbook.Range("Sheet1!B2:B100"), _
target := ThisWorkbook.Range("Sheet1!C2")
End Sub
Sub GetMaxByGroupTo(sourceGroups As Range, sourceValues As Range, target As Range)
Dim dict As Object, groups(), values(), r As Long, max
Set dict = CreateObject("Scripting.Dictionary")
groups = sourceGroups.Value2
values = sourceValues.Value2
' store the maximum value of each group in a dictionary for an efficient lookup '
For r = Lbound(groups) to Ubound(groups)
max = dict(groups(r, 1))
If VarType(max) And values(r, 1) <= max Then Else dict(groups(r, 1)) = values(r, 1)
Next
' build and copy the result array to the sheet '
For r = Lbound(groups) to Ubound(groups)
values(r, 1) = dict(groups(r, 1))
Next
target.Resize(Ubound(groups), 1).Value2 = values
End Sub
Related
I am looking for if it is possible to get the data and headers from a table as in the example image and have the output go to two columns with the first column being a repeating header? I did try the transpose however the email row kept populating up to column E.
Please, try the next way. It uses arrays being fast even for large ranges, mostly working in memory. It returns starting from "F2". It is able to process any other columns you (may) need, after "Status":
Sub TransposeMails()
Dim sh As Worksheet, lastR As Long, lastCol As Long
Dim arrH, arr, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet 'use here the necessary sheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).column 'last column
arrH = Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2) 'place headers in an array
arr = sh.Range("A2", sh.cells(lastR, lastCol)).Value2 'place the range to be processed (except headers) in an array for faster iteration/processing
ReDim arrFin(1 To (UBound(arrH) + 1) * UBound(arr), 1 To 2) 'Redim the final array (keeping the processed result)
'+ 1 for the empty rows in between...
For i = 1 To UBound(arr)
For j = 1 To UBound(arrH)
k = k + 1
arrFin(k, 1) = arrH(j, 1): arrFin(k, 2) = arr(i, j)
Next j
k = k + 1 'for the empty row between groups...
Next i
'drop the processed array content:
sh.Range("G2").Resize(UBound(arrFin), 2).Value2 = arrFin
End Sub
The code can be easily adapted to return anywhere (another sheet, workbook, range etc).
The range to be processed must start from "A1" ("Email" header) and not having any other record after the last header (on the first row)...
Transpose Data
Sub TransposeData()
Const SRC_NAME As String = "Sheet1"
Const DST_NAME As String = "Sheet1"
Const DST_FIRST_CELL As String = "A8"
Const EMPTY_COLS As Long = 0
Const EMPTY_ROWS As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim drOffset As Long: drOffset = srg.Columns.Count + EMPTY_ROWS
Dim dcOffset As Long: dcOffset = 1 + EMPTY_COLS
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Application.ScreenUpdating = False
Dim srrg As Range, shrg As Range
Dim IsHeaderReady As Boolean, IsFirstRowDone As Boolean
For Each srrg In srg.Rows
If Not IsHeaderReady Then
srrg.Copy
dfCell.PasteSpecial Transpose:=True
Set shrg = dfCell.Resize(srg.Columns.Count) ' transpose no more
IsHeaderReady = True
Else ' header is ready; it's already copied for the first data row
If IsFirstRowDone Then shrg.Copy dfCell Else IsFirstRowDone = True
srrg.Copy
dfCell.Offset(, dcOffset).PasteSpecial Transpose:=True
Set dfCell = dfCell.Offset(drOffset)
End If
Next srrg
Application.ScreenUpdating = True
MsgBox "Data transposed.", vbInformation
End Sub
If I understand you correctly
Sub test()
'set the range of the header as rg variable
'count how many data under EMAIL header as cnt variable
Dim rg As Range: Set rg = Range("A1", Range("A1").End(xlToRight))
Dim cnt As Integer: cnt = Range(rg, rg.End(xlDown)).Rows.Count - 1
Dim i As Integer: Dim rslt As Range
'loop to each range with data as many as the cnt value
'prepare the result range as rslt variable
'put the value of header name to rslt range
'put the looped range value to rslt.offset(0,1)
For i = 1 To cnt
Set rslt = Range("A" & Rows.Count).End(xlUp).Offset(3, 0) _
.Resize(rg.Columns.Count, 1)
rslt.Value = Application.Transpose(rg)
rslt.Offset(0, 1).Value = Application.Transpose(rg.Offset(i, 0))
Next
End Sub
Please note, the code must be run where the sheet contains the data is active.
When I run this code, it is getting a subscript out of range error in this specific line:
If i = ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1).End(xlUp).Row Then
arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = i ' <-- This line
End If
I unfortunately did not write this code, but my understanding is that i is supposed to be the upper bound of the array above. I've tried troubleshooting a bit and it appears that arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = 0 which would suggest that the Array is unallocated and therefore the error is coming from somewhere above this line. From what I have read it could be from the redim portions but I've tried ReDim arr_Test_Case_Rows(1 To 2, 1 To 1) right before the error line and while it ran, the results did not populate as expected. Anything I can do here to fix this?
Sub Populate_Test_Matrix()
Dim str_External_Test_Matrix_Name As String
Dim ws_External_Test_Matrix As Worksheet
Dim ws_TestMatrix_Tab As Worksheet
Dim ws_ItemInputs As Worksheet
Dim ws_ItemOutputs As Worksheet
Dim rng_Header_Copy_Start As Range
Dim rng_Header_Copy_End As Range
Dim rng_Copy_Start As Range
Dim rng_Copy_End As Range
Dim rng_Paste_Start As Range
Dim i As Long
Dim j As Long
Dim arr_Test_Case_Rows() As Variant
Dim boo_Empty_Row_Ind As Boolean
Dim xlx As XlXmlExportResult
Dim xmlmp As XmlMap
Dim str_Replace_String As String
Dim arr_XML_String_Holder() As Variant
Dim str_XML_Save_Name As String
Dim str_Record As String
Dim str_State As String
Dim int_Test_Case_Start_Row As Long
Application.ScreenUpdating = False
str_External_Test_Matrix_Name = Open_Workbook(ThisWorkbook.Sheets("Macro_Menu").Range("Test_Case_Matrix_Path").Value)
Set ws_External_Test_Matrix = Workbooks(str_External_Test_Matrix_Name).Sheets("MATRIX")
Set ws_TestMatrix_Tab = ThisWorkbook.Sheets("TESTMatrix")
Set ws_ItemInputs = ThisWorkbook.Sheets("ITEMINPUTS")
Set ws_ItemOutputs = ThisWorkbook.Sheets("ITEMOUTPUTS")
'Get start and end row numbers of test cases from External Test Matrix, and record into array
boo_Empty_Row_Ind = False
'Determine first row (header row) of Test Cases, to determine which row to begin looping from when
'finding Test Cases
int_Test_Case_Start_Row = ws_External_Test_Matrix.Range("A:A").Find(what:="Record", LookIn:=xlValues, LookAt:=xlWhole, After:=ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1)).Row
For i = int_Test_Case_Start_Row To ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1).End(xlUp).Row
'If 0, then row is empty
If (Application.CountA(ws_External_Test_Matrix.Cells(i, 1).EntireRow) = 0) And _
(ws_External_Test_Matrix.Cells(i, 1).EntireRow.Interior.ColorIndex = 1) Then 'If 1, then row is colored black
If boo_Empty_Row_Ind = False And (Not Not arr_Test_Case_Rows) <> 0 Then 'Array is allocated
arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = i - 1
End If
boo_Empty_Row_Ind = True
Else 'Row is NOT empty
'If we previously hit empty row and current row is now non-empty, we have test case to record
If boo_Empty_Row_Ind = True Then
boo_Empty_Row_Ind = False
If (Not Not arr_Test_Case_Rows) = 0 Then 'if 0, then array is unallocated
ReDim arr_Test_Case_Rows(1 To 2, 1 To 1)
Else
ReDim Preserve arr_Test_Case_Rows(1 To 2, 1 To UBound(arr_Test_Case_Rows, 2) + 1)
End If
'arr_Test_Case_Rows(1, X) = start row of test case
'arr_Test_Case_Rows(2, X) = end row of test case
arr_Test_Case_Rows(1, UBound(arr_Test_Case_Rows, 2)) = i
End If
End If
'If I = last row of loop counter
If i = ws_External_Test_Matrix.Cells(ws_External_Test_Matrix.Rows.Count, 1).End(xlUp).Row Then
arr_Test_Case_Rows(2, UBound(arr_Test_Case_Rows, 2)) = i ' <-- This line
End If
Next i
The business case context- the broader program that this module is in takes in a sheet of data and reformats it to be uploaded in another program.
The sheet is made up of one header row followed by rows of records of varying size (1 record could be 1 row, all the way up to 7). The blank rows are used to separate when one record ends and another begins.
This particular module is recording where records exist (not blank row) and the line where it breaks is referring to the final non blank row in the sheet.
In this screenshot it is 40 rows, but the actual case is 55.
Here's a slightly different approach using a Collection instead of an array:
Sub Populate_Test_Matrix()
Dim wb As Workbook, extWb As Workbook, wsExtTM As Worksheet, colRecs As Collection
Dim inRecord As Boolean, firstRecordRow, lastRow As Long
Dim rw As Range, rec, startRow As Long
'better for Open_Workbook to return a reference to the workbook, instead of its name...
Set extWb = Open_Workbook(wb.Sheets("Macro_Menu").Range("Test_Case_Matrix_Path").Value)
Set wsExtTM = extWb.Sheets("MATRIX")
firstRecordRow = Application.Match("Record", wsExtTM.Columns("A"), 0)
If IsError(firstRecordRow) Then
MsgBox "'Record' not found in ColA", vbCritical
Exit Sub
End If
Set colRecs = New Collection 'using a collection seems simpler
inRecord = False
Set rw = wsExtTM.Rows(firstRecordRow)
lastRow = wsExtTM.Cells(wsExtTM.Rows.Count, 1).End(xlUp).Row
Do While rw.Row <= lastRow
If Not RowIsEmpty(rw) Then
If Not inRecord Then
startRow = rw.Row 'save the start row
inRecord = True
End If
Else
If inRecord Then 'were we previously in a record?
colRecs.Add Array(startRow, rw.Row - 1)
inRecord = False
End If
End If
Set rw = rw.Offset(1, 0) 'next row
Loop
colRecs.Add Array(startRow, lastRow) 'close the last record
For Each rec In colRecs
Debug.Print "Start row:" & rec(0), "End row:" & rec(1)
Next rec
End Sub
'factored out a bit of logic...
Function RowIsEmpty(rw As Range) As Boolean
'using color not colorindex...
RowIsEmpty = Application.CountA(rw) = 0 And rw.Interior.Color = vbBlack
End Function
I want to check if the current destination string is located within the destination search array once the origins match up. The outcome is supposed to be all flights between any originSearch city and destinationSearch city and the corresponding flight number
I was playing with a boolean that stores all the true matches but I got confused.
Sub Matches()
Dim nFlights As Integer
Dim origin() As String
'Dim isOwned() As Boolean
Dim flightNumber() As String
Dim destination() As String
Dim iOrigin As Integer
Dim iDestination As Integer
Dim iFlight As Integer
Dim nOrigins As Integer
Dim nDestinations As Integer
Dim originSearch() As String
Dim destinationSearch() As String
Dim i As Integer
Dim x As Integer
Dim m As Integer
With wsData.Range("A1")
nFlights = Range(.Offset(1, 0), .End(xlDown)).Rows.Count
ReDim origin(1 To nFlights)
ReDim flightNumber(1 To nFlights)
ReDim destination(1 To nFlights)
'ReDim isOwned(1 To nFlights)
'stores the origin column in an array
For iOrigin = 1 To nFlights
'isOwned(iOrigin) = False
origin(iOrigin) = .Offset(iOrigin, 0).Value
Next
'stores the destination column in an array
For iDestination = 1 To nFlights
'isOwned(iDestination) = False
destination(iDestination) = .Offset(iDestination, 1).Value
Next
'stores the flight column in an array
For iFlight = 1 To nFlights
'isOwned(iFlight) = False
flightNumber(iFlight) = .Offset(iFlight, 2).Value
Next
End With
With wsData.Range("E1")
nOrigins = Range(.Offset(1, 0), .End(xlDown)).Rows.Count
nDestinations = 4 'Range(.Offset(1, 1), .End(xlDown)).Rows.Count
ReDim originSearch(1 To nOrigins)
ReDim destinationSearch(1 To nDestinations)
For i = 1 To nOrigins
originSearch(i) = .Offset(i, 0).Value
For x = 1 To nDestinations
destinationSearch(x) = .Offset(x, 1).Value
For m = 1 To nFlights
If origin(m) = originSearch(i) And destination(m) = destinationSearch(x) Then
wsData.Range("H1").Offset(i, 0).Value = originSearch(i)
wsData.Range("H1").Offset(x, 1).Value = destinationSearch(x)
wsData.Range("H1").Offset(x, 2).Value = flightNumber(m)
End If
Next m
Next x
Next i
End With
End Sub
I think you can solve the problem with this formula:
=FILTER(AllFlights;IFNA(MATCH(AllFlights[Origin];DesiredOrigin;0)*MATCH(AllFlights[Destination];DesiredDestination;0);0);)
Here:
AllFlights is the name of a table with all possible flights;
DeiredOrigin is the name of a table with origins of interest;
DeiredDestination is the name of a table with destinations of interest;
Multiplication of Matches is the matrix equivalent of the OR operator.
p.s. Instead of IFNA we can use ISNUMBER:
=FILTER(AllFlights;ISNUMBER(MATCH(AllFlights[Origin];DesiredOrigin;0)*MATCH(AllFlights[Destination];DesiredDestination;0));)
There should only be a single nested for loop at the end there.
So for each origin_dest-pair search value,
you're searching each origin_dest-pair record value.
This adds all the flight numbers of matching scenarios into an array and then puts the flight numbers into the next available column.
Also Ranges are essentially Variant() arrays, so you can just assign one to the other, instead of iterating through each value.
Option Compare Text
Sub FindFlightNumbers()
Dim orig() As Variant: orig = Range("A2:A" & Range("A2").End(xlDown).Row)
Dim dest() As Variant: dest = Range("B2:B" & Range("B2").End(xlDown).Row)
Dim flight_nums() As Variant: flight_nums = Range("C2:C" & Range("C2").End(xlDown).Row)
'Turn 2-D arrays into 1-D arrays
orig = Application.Transpose(orig)
dest = Application.Transpose(dest)
flight_nums = Application.Transpose(flight_nums)
Dim orig_search As Range: Set orig_search = Range("E2:E" & Range("e2").End(xlDown).Row)
Dim search_cell As Range, i As Integer
For Each search_cell In orig_search
Dim match_numbers() As Variant
For i = 1 To UBound(orig)
If search_cell.Value = orig(i) And search_cell.Offset(0, 1).Value = dest(i) Then
'If its the first match, init the array
If (Not match_numbers) = -1 Then
ReDim Preserve match_numbers(0)
match_numbers(0) = flight_nums(i)
Else
'Otherwise increment the array
ReDim Preserve match_numbers(UBound(match_numbers) + 1)
match_numbers(UBound(match_numbers)) = flight_nums(i)
End If
End If
Next i
'If the array had found matches, store them; comma-delimited
If Not Not match_numbers Then
search_cell.Offset(0, 2).Value = Join(match_numbers, ",")
End If
Erase match_numbers
Next search_cell
End Sub
Here's an approach using Match() directly against the search values on the worksheet:
Sub Matches()
Dim data, m As Long, rngOrigin As Range, rngDest As Range, m As Long, i As Long
'one array of all data: origin|destination|flight#
data = wsdata.Range("A2", wsdata.Cells(Rows.Count, "C").End(xlUp))
'set search ranges
Set rngOrigins = wsdata.Range("E2", wsdata.Cells(Rows.Count, "E").End(xlUp))
Set rngDest = wsdata.Range("F2", wsdata.Cells(Rows.Count, "F").End(xlUp))
'loop all source data
For m = 1 To UBound(data, 1)
'check Match() against search ranges
If Not IsError(Application.Match(data(m, 1), rngOrigins, 0)) Then
If Not IsError(Application.Match(data(m, 2), rngDest, 0)) Then
i = i + 1
wsdata.Range("H1").Offset(i, 0).Resize(1, 3) = _
Array(data(m, 1), data(m, 2), data(m, 3))
End If
End If
Next m
End Sub
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
Hopefully i've phrased that right...
I came across something online stating that copy and pasting wastes precious time. It's better to assign values more directly, without using excel functions.
I found a section in a VBA book explaining how to store a range in a 2D array.
Now what if I wanted to copy and paste a range from a dynamic number of worksheets into another one main sheet with this method?
In my head, I imagine stacking more and more values into an array, then dumping the array where I'd like it to go, into a range whose size is defined by the dimensions of the big array.
In practice, all I have managed to create is something like the below, performing the same simple action for each worksheet in turn.
Is it possible to do this better? That runs faster? Help a brother out!
Sub arrayCopyPaste()
Dim Obj As Range
Dim Data As Variant
Dim ws As Worksheet
Dim sheetCount As Integer
Dim LR As Integer
sheetCount = Sheets.Count
Set ws = Sheets.Add
ws.Move After:=Worksheets(Worksheets.Count)
For i = 1 To sheetCount
Data = Sheets(i).Range("A1:B9")
LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set Obj = ws.Range("A" & LR)
Set Obj = Obj.Resize(UBound(Data, 1), UBound(Data, 2))
Obj.Value = Data
Next i
End Sub
With just about any code I use, I like to make a call to this routine I made:
Sub SpeedupCode(Optional ByVal Val As Boolean = True)
With Application
If Val = True Then
.ScreenUpdating = False
.Calculation = xlCalculationManual
Else
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End If
End With
End Sub
So, in your code you would simply use it as follows:
Sub arrayCopyPaste()
Dim Obj As Range
Dim Data As Variant
Dim ws As Worksheet
Dim sheetCount As Integer
Dim LR As Integer
SpeedupCode
sheetCount = Sheets.Count
Set ws = Sheets.Add
ws.Move After:=Worksheets(Worksheets.Count)
For i = 1 To sheetCount
Data = Sheets(i).Range("A1:B9")
LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set Obj = ws.Range("A" & LR)
Set Obj = Obj.Resize(UBound(Data, 1), UBound(Data, 2))
Obj.Value = Data
Next i
SpeedupCode False
End Sub
While this does not necessarily optimize your code, it can significantly improve the performance on every project that you do. In the event that your code requires a newly calculated variable in your worksheet, you can always use Application.Calculate before you grab that variable, but generally, it shouldn't be needed.
I'd be inclined to use your current approach and just boil it down a bit.
Sub arrayCopyPaste()
Dim ws As Worksheet
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count))
For i = 1 To Sheets.Count - 1
With Sheets(i).Range("A1:B9")
ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize( _
.Rows.Count, .Columns.Count).Value = .Value
End With
Next i
End Sub
This version is slightly more efficient due to writing the results all at once, though you probably won't notice much of a difference unless you're working with very large ranges.
Sub test()
'Same as original: final array is 2 columns wide, (3 * number of sheets) rows long
Call mergeRangeValues("A1:B3", "Results", True)
'Alternate version: final array is 3 rows long, (2 * number of sheets) columns wide
'Call mergeRangeValues("A1:B3", "Results", False)
End Sub
Sub mergeRangeValues(rngString As String, newWSName As String, stackRows As Boolean)
'Merges the same range (rngString) from all sheets in a workbook
'Adds them to a new worksheet (newWSName)
'If stackRows = True, values are stacked vertically
'If stackRows = False, values are stacked horizontally
Dim sheetCount As Long
Dim newWS As Worksheet
sheetCount = ThisWorkbook.Sheets.Count
Set newWS = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(sheetCount))
newWS.Name = newWSName
Dim numCols As Long
Dim numRows As Long
numCols = newWS.Range(rngString).Columns.Count * IIf(stackRows, 1, sheetCount)
numRows = newWS.Range(rngString).Rows.Count * IIf(stackRows, sheetCount, 1)
ReDim resultsArr(1 To numRows, 1 To numCols) As Variant
'''Longer version:
'If stackRows Then
'numCols = newWS.Range(rngString).Columns.Count
'numRows = newWS.Range(rngString).Rows.Count * sheetCount
'Else
'numCols = newWS.Range(rngString).Columns.Count * sheetCount
'numRows = newWS.Range(rngString).Rows.Count
'End If
'''ie "If you want to stack the results vertically, make the array really long"
'''or "If you want to stack the results horizontally, make the array really wide"
Dim i As Long
For i = 0 To sheetCount - 1
Dim tempArr As Variant
tempArr = ThisWorkbook.Sheets(i + 1).Range(rngString).Value
Dim j As Long
Dim k As Long
If stackRows Then
For j = LBound(tempArr, 1) To UBound(tempArr, 1)
For k = LBound(tempArr, 2) To UBound(tempArr, 2)
resultsArr(j + i * (numRows / sheetCount), k) = tempArr(j, k)
Next
Next
Else
For j = LBound(tempArr, 1) To UBound(tempArr, 1)
For k = LBound(tempArr, 2) To UBound(tempArr, 2)
resultsArr(j, k + i * (numCols / sheetCount)) = tempArr(j, k)
Next
Next
End If
Next
With newWS
.Range(.Cells(1, 1), .Cells(numRows, numCols)).Value = resultsArr
End With
End Sub