Related
for belows code the line vItemsNotInMaster(k) = vCheckItems(i) throws a type mismatch error once the array vItemsNotInMaster shall be populated. I am not sure why - as the caller sub and function array variables are all declared as Variants and types did not change according to the Locals Window.
I tried different data types but, this does throw other error messages.
Public Sub Testing()
Dim myArray1(1 To 4) As Variant
Dim myArray2(1 To 4) As Variant
Dim myArray3 As Variant
myArray1(1) = "one1"
myArray1(2) = "two3"
myArray1(3) = "three5"
myArray1(4) = "four7"
myArray2(1) = "one1"
myArray2(2) = "two3"
myArray2(3) = "different"
myArray2(4) = "four7"
myArray3 = Comparing_TwoArrays(myArray1, myArray2)
Stop
End Sub
Public Function Comparing_TwoArrays(ByVal vCheckItems As Variant, ByVal vMasterList As Variant) As Variant
Dim vItemsNotInMaster As Variant
Dim isMatch As Boolean
Dim i As Integer
Dim j As Integer
Dim k As Integer
ReDim vArray3(1 To UBound(vCheckItems, 1) + UBound(vMasterList, 1))
k = 1
For i = LBound(vCheckItems, 1) To UBound(vCheckItems, 1)
isMatch = False
For j = LBound(vMasterList, 1) To UBound(vMasterList, 1)
If vCheckItems(i) = vMasterList(j) Then
isMatch = True
Exit For
End If
Next j
If (isMatch = False) Then
vItemsNotInMaster(k) = vCheckItems(i) '---> Throws type mismatch
k = k + 1
End If
Next i
If (k > 1) Then
ReDim Preserve vArray3(1 To k - 1)
Else
vArray3 = Empty
End If
Comparing_TwoArrays = vArray3
End Function
Does someone has an idea?
Code Example credited to: https://bettersolutions.com/vba/arrays/comparing.htm
As I said in my comment, replacing vItemsNotInMaster(k) = vCheckItems(i) with vArray3(k) = vCheckItems(i) will solve the problem.
But if you need learning arrays manipulation, the next more compact code returns the same in less code lines number:
Public Sub Testing_()
Dim myArray1(1 To 4) As String
Dim myArray2(1 To 4) As String
Dim myArray3 As Variant
myArray1(1) = "one1"
myArray1(2) = "two2"
myArray1(3) = "three5"
myArray1(4) = "four7"
myArray2(1) = "one1"
myArray2(2) = "two3"
myArray2(3) = "different"
myArray2(4) = "four7"
myArray3 = Application.IfError(Application.match(myArray1, myArray2, 0), "x") 'it palces "x" when not a match...
Debug.Print Join(myArray3, "|") 'just to visually see the return...
'for a single case:
Debug.Print "(first) missing element: " & myArray1(Application.match("x", myArray3, 0)) 'it returns according to the first occurrence
'For more than one missing occurrence:
Dim i As Long
For i = 1 To UBound(myArray3)
If myArray3(i) = "x" Then
Debug.Print "Missing: " & myArray1(i)
End If
Next i
End Sub
To return occurrences independent of array elements position, it is also simpler to use Application.Match (with a single iteration). If interested, I can also post such a function...
As pointed out by #FunThomas the function does not return anything. Fix for type mismatch error is to Redim the vItemsNotInMaster array for each new item, while preserving the already populated values.
The vArray3 variable does not make sense and function should be rewritten as:
Public Function Comparing_TwoArrays(ByVal vCheckItems As Variant, ByVal vMasterList As Variant) As Variant
Dim vItemsNotInMaster()
Dim isMatch As Boolean
Dim i As Integer
Dim j As Integer
Dim k As Integer
k = 1
For i = LBound(vCheckItems, 1) To UBound(vCheckItems, 1)
isMatch = False
For j = LBound(vMasterList, 1) To UBound(vMasterList, 1)
If vCheckItems(i) = vMasterList(j) Then
isMatch = True
Exit For
End If
Next j
If (isMatch = False) Then
ReDim Preserve vItemsNotInMaster(1 To k)
vItemsNotInMaster(k) = vCheckItems(i) '---> Throws type mismatch
k = k + 1
End If
Next i
Comparing_TwoArrays = vItemsNotInMaster
End Function
Return Matching Array Elements
The function will return an array of the not matching elements from the check array in the master array.
If all elements are matching (are found in master), it will return an array whose upper limit is less than its lower limit.
Option Explicit
Public Sub Testing()
Dim myArray1(1 To 4) As Variant
Dim myArray2(1 To 4) As Variant
Dim myArray3 As Variant
myArray1(1) = "one1"
myArray1(2) = "two3"
myArray1(3) = "three5"
myArray1(4) = "four7"
myArray2(1) = "one1"
myArray2(2) = "two3"
myArray2(3) = "different"
myArray2(4) = "four7"
myArray3 = NotInMasterArray(myArray1, myArray2)
If LBound(myArray3) <= UBound(myArray3) Then
' Column
Debug.Print "Column" & vbLf & Join(myArray3, vbLf)
' Delimited row:
Debug.Print "Row" & vbLf & Join(myArray3, ",")
Else
Debug.Print "All elements from Check array found in Master array."
End If
Stop
End Sub
Public Function NotInMasterArray( _
arrCheck() As Variant, _
arrMaster() As Variant, _
Optional ByVal ResultLowerLimit As Variant) _
As Variant()
' Write the check array's limits to variables.
Dim cLB As Variant: cLB = LBound(arrCheck)
Dim cUB As Long: cUB = UBound(arrCheck)
' Determine the lower limit ('nLB') of the result array.
Dim nLB As Long
If IsMissing(ResultLowerLimit) Then ' use the check array's lower limit
nLB = cLB
Else ' use the given lower limit
nLB = ResultLowerLimit
End If
' Calculate the result array's upper limit.
Dim nUB As Long: nUB = cUB - cLB + nLB
' Define the initial result array ('arrNot') making it the same size
' as the check array (it is possibly too big; it is only of the correct size,
' if all check array's elements are not found in the master array).
Dim arrNot() As Variant: ReDim arrNot(nLB To nUB)
' Write the result array's lower limit decreased by 1 to the result
' array's limit counter variable (to first count and then write).
Dim n As Long: n = nLB - 1
Dim c As Long ' Check Array Limit Counter
' Loop through the elements of the check array.
For c = cLB To cUB
' Check if the current element is not found in the master array.
If IsError(Application.Match(arrCheck(c), arrMaster, 0)) Then
n = n + 1 ' count
arrNot(n) = arrCheck(c) ' write
'Else ' found in master; do nothing
End If
Next c
If n < nLB Then ' all found in master
arrNot = Array() ' i.e. UBound(arrNot) < LBound(arrNot)
Else ' not all are found in master
If n < nUB Then ' not all elements are not found...
ReDim Preserve arrNot(nLB To n) ' ... resize to 'n'
'Else ' all elements are not found; do nothing
End If
End If
' Assign the result array to the result of the function.
NotInMasterArray = arrNot
End Function
I have 2-dimensional array and I would like to inspect each element in a specific row with If-Then statements and assign assign values to the next row depending on the outcome of the If-Then statements? What is the correct syntax for looping through the elements of a row in a 2-d array?
Please, try using the next Sub:
Sub changeRow(arr As Variant, iR As Long, strTxt As String)
Dim i As Long
For i = LBound(arr, 2) To UBound(arr, 2) '(arr, 2) to determine the number of columns
arr(iR, i) = arr(iR, i) & strTxt
Next i
End Sub
Of course, it can be designed to do whatever you need on the respective row. Even extending parameters to be used.
It can easily be tested in the next way:
Sub testIterate2DArrayRow()
Dim sh As Worksheet, arr, arrR, iRow As Long, strAdd As String
Set sh = ActiveSheet
iRow = 2 'the array row to be iterated
strAdd = " - XX" 'string to be added to each row element (instructional example)
arr = sh.Range("A2:D6").value 'the easiest way to create a 2D array
arrR = Application.Index(arr, iRow, 0) 'create a 1D slice of the row to be iterated/modified
'if you need only iterating to extract something, you may stop here
'and iterate between its elements...
Debug.Print Join(arrR, "|") 'just to visually see the row content
changeRow arr, iRow, strAdd 'iterate on the iRow row (and modify something)
Debug.Print Join(Application.Index(arr, iRow, 0), "|") 'visual evidence of the modification...
End Sub
Edited:
I will let the above code for other people liking to learn the general concept.
Please, test the next code, which should process the array as (I understood) you need.
Its first lines only create the opportunity to easily check the concept. So, you should place the necessary bays on an Excel sheet, from "A1" to "J1" and run the above code. It will return the processed array starting from "L1":
Sub analizeBays()
Dim sh As Worksheet, BayRay(), i As Long
Set sh = ActiveSheet
BayRay = sh.Range("A1:J4").value 'only to easily test the concept
For i = LBound(BayRay, 2) To UBound(BayRay, 2)
If BayRay(1, i) <= 10 Then
BayRay(2, i) = 2035
BayRay(3, i) = 2005
BayRay(4, i) = 1005
ElseIf BayRay(1, i) > 10 And BayRay(1, i) <= 12 Then
BayRay(2, i) = 2022
BayRay(3, i) = 1032
BayRay(4, i) = 4344
End If
Next i
'drop the processed array content starting from "L1")
sh.Range("L1").Resize(UBound(BayRay), UBound(BayRay, 2)).value = BayRay
End Sub
Loop Through a Row of a 2D Array
Option Explicit
Sub LoopThroughRow()
Const RowIndex As Long = 2
Const Criteria As Double = 3
Const MinNum As Long = 1
Const MaxNum As Long = 5
' Populate with random integers.
Dim Data As Variant: ReDim Data(1 To 5, 1 To 5)
Dim r As Long, c As Long
For r = LBound(Data, 1) To UBound(Data, 1)
For c = LBound(Data, 2) To UBound(Data, 2)
Data(r, c) = Int((MaxNum - MinNum + 1) * Rnd + MinNum)
Next c
Next r
' Write criteria row.
For c = LBound(Data, 2) To UBound(Data, 2)
If Data(RowIndex, c) > Criteria Then
Data(RowIndex + 1, c) = "Yes"
Else
Data(RowIndex + 1, c) = "No"
End If
Next c
' Print result.
Debug.Print "Column", "Row " & RowIndex, "Row " & RowIndex + 1
For c = LBound(Data, 2) To UBound(Data, 2)
Debug.Print c, Data(RowIndex, c), Data(RowIndex + 1, c)
Next c
End Sub
I'm new to coding with VBA, and a beginner programmer in general. I have the following simple table (the data keeps getting inputted on daily basis, so it changes):
Item #
Description
Date
Location
Plate
Load
Type
Rate
Cost
0001
des1
30/1/21
Site
ABC123
5
One
typ1
100
0002
des2
30/1/21
Office
ACB465
4
One
typ1
100
0003
des3
30/1/21
Office
ABC789
3
One
typ1
100
0004
des4
30/1/21
Site
ABS741
5
One
typ1
100
0005
des4
31/1/21
Office
ABC852
2
One
typ1
100
I would like to filter this data by specific date first, then delete duplicates in Location while adding the Load for said duplicates.
For example, if I wanted to filter for 30/1/21. It would end up as follows:
Location
Load
Site
10
Office
7
I would then want to put it in one summary cell as follows:
Summary
10 Site, 7 Office
I was able to filter the original table into jagged arrays. The code for that is:
For j = numberSkipD To numberRowsD
If Worksheets("Disposal Fees").Range("F" & j).Value = Worksheets("Daily Tracking").Range("B2").Value Then
For k = numberDisposalInformationRaw To numberDisposalLocation
ReDim Preserve disposalLocation(numberDisposalLocation)
disposalLocation(numberDisposalLocation) = Worksheets("Disposal Fees").Range("I" & j).Value
Next
numberDisposalLocation = numberDisposalLocation + 1
For k = numberDisposalInformationRaw To numberDisposalLoad
ReDim Preserve disposalLoad(numberDisposalLoad)
disposalLoad(numberDisposalLoad) = Worksheets("Disposal Fees").Range("K" & j).Value
Next
numberDisposalLoad = numberDisposalLoad + 1
End If
Next
I then tried to do the second table above (deleting duplicates and adding the values for said duplicates together) but it is giving me errors, not sure how to solve them. I know they're index errors, but don't know how to fix them. (Please help me with this part, here is the code)
Dim disposalInformationRaw As Variant
Dim disposalInformationCooked As Variant
Dim FoundIndex As Variant, MaxRow As Long, m As Long
ReDim disposalInformationCooked(1 To UBound(disposalInformationRaw, 1), 1 To UBound(disposalInformationRaw, 2))
MaxRow = 0
For m = 1 To UBound(disposalInformationRaw, 1)
FoundIndex = Application.Match(disposalInformationRaw(m, 1), Application.Index(disposalInformationCooked, 0, 1), 0)
If IsError(FoundIndex) Then
MaxRow = MaxRow + 1
FoundIndex = MaxRow
disposalInformationCooked(FoundIndex, 1) = disposalInformationRaw(m, 1)
End If
disposalInformationCooked(FoundIndex, 2) = Val(disposalInformationCooked(FoundIndex, 2)) + Val(disposalInformationRaw(i, 2))
Next m
Range("G1").Resize(MaxRow, UBound(disposalInformationCooked, 2)).Value = disposalInformationCooked
I don't think I'd have much trouble finalizing the third part (the summary), but if you know how to do it, please feel free to share how you would approach it. I mostly need help with the second part. I would be more than happy to edit and provide more information if needed. Thanks in advance.
Here's one approach using a dictionary.
dim dict, rw as range, locn, k, msg, theDate
set dict= createobject("scripting.dictionary")
theDate = Worksheets("Daily Tracking").Range("B2").Value
'adjust table range as required
for each rw in worksheets("Disposal Fees").range("F6:K100").rows
if rw.cells(3).Value = theDate Then 'date match?
locn = rw.cells(4).Value 'read location
dict(locn) = dict(locn) + rw.cells(6).Value 'add load to sum
end if
next rw
'loop over the dictionary keys and build the output
for each k in dict
msg = msg & IIf(len(msg) > 0, ", ", "") & dict(k) & " " & k
next k
debug.print msg
Sum Unique
Disposal Fees
Daily Tracking
Adjust the values in the constants section.
The Code
Option Explicit
Sub TESTsumByValue()
' Source
Const srcName As String = "Disposal Fees"
Const lCol As Long = 3
Const kCol As Long = 4
Const sCol As Long = 6
Const SumFirst As Boolean = True
Const KSDel As String = ":"
Const IDel As String = ", "
' Destination
Const dstName As String = "Daily Tracking"
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define Source Range (You may have to do something different).
Dim srg As Range: Set srg = wb.Worksheets(srcName).Range("A1").CurrentRegion
' Write Criteria to variable.
Dim drg As Range: Set drg = wb.Worksheets(dstName).Range("B2")
Dim Criteria As Variant: Criteria = drg.Value
' Use function to get the result.
Dim s As String
s = sumByValue(Criteria, srg, lCol, kCol, sCol, SumFirst, KSDel, IDel)
Debug.Print s ' "10:Site, 4:Bathroom, 4:Office"
drg.Offset(, 3).Value = s ' writes to 'E2'
End Sub
Function sumByValue( _
ByVal LookupValue As Variant, _
rng As Range, _
ByVal LookupColumn As Long, _
ByVal KeyColumn As Long, _
ByVal SumColumn As Long, _
Optional ByVal SumFirst As Boolean = False, _
Optional ByVal KeySumDelimiter As String = ": ", _
Optional ByVal ItemsDelimiter As String = ", ") _
As String
' Validate range ('rng').
If rng Is Nothing Then Exit Function
' Write values from range to Data Array ('Data').
Dim Data As Variant: Data = rng.Value ' 2D one-based array
' Declare additional variables.
Dim vKey As Variant ' Current Key Value
Dim vSum As Variant ' Current Sum Value
Dim i As Long ' Data Array Row Counter
' Create a reference to Unique Sum Dictionary (no variable).
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare ' 'A = a'
' Loop through Data Array ('Data') and write and sumup unique values
' to Unique Sum Dictionary.
For i = 1 To UBound(Data, 1)
If Data(i, LookupColumn) = LookupValue Then
vKey = Data(i, KeyColumn)
If Not IsError(vKey) Then
If Len(vKey) > 0 Then
vSum = Data(i, SumColumn)
If IsNumeric(vSum) Then
.Item(vKey) = .Item(vKey) + vSum
Else
.Item(vKey) = .Item(vKey) + 0
End If
End If
End If
End If
Next i
' Validate Unique Sum Dictionary.
If .Count = 0 Then Exit Function
' Redefine variables to be reused.
ReDim Data(1 To .Count) ' Result Array: 1D one-based array
i = 0 ' Result Array Elements Counter
' Write results to Result Array.
If SumFirst Then
For Each vKey In .Keys
i = i + 1
Data(i) = .Item(vKey) & KeySumDelimiter & vKey
Next vKey
Else
For Each vKey In .Keys
i = i + 1
Data(i) = vKey & KeySumDelimiter & .Item(vKey)
Next vKey
End If
End With
' Write the elements of Data Array to Result String.
sumByValue = Join(Data, ItemsDelimiter)
End Function
I have a giant dataset that looks like this
I am trying to go down the list of different companies and grab 3 per company and combine them. Based on the photo above, I would have 2 different lists with 3 companies each (except TH Repair which will have 2 in the final list).
My real dataset contains hundreds of different companies, each with dozens/hundreds of entries so I would finish with dozens of lists (each potentially hundreds long).
I tried to record a macro and ended up with this code
Sub Loop1()
'
' Loop1 Macro
'
'
Range("A4:E6").Select
Selection.Copy
Sheets("Sheet3").Select
Range("A18").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A11:E13").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A21").Select
ActiveSheet.Paste
Sheets("Sheet2").Select
Range("A17:E19").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet3").Select
Range("A24").Select
ActiveSheet.Paste
End Sub
However, this turned out to be WAY more complicated then I expected.
I am looking for the end result to look like this
See if something like this works for you. I only ran one scenario through it so you will want to test it more.
This makes the assumption that the data is sorted by column B on the original sheet
This procedure makes an assumption that there is either headers or no data on row 1.
You will need to change the "Sheet1" in this line Set ws1 = ActiveWorkbook.Worksheets("Sheet1") to the name of the sheet you are starting with.
Option Explicit
Public Sub MoveData()
Dim ws1 As Worksheet
Set ws1 = ActiveWorkbook.Worksheets("Sheet1")
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets.Add()
Dim rw As Long
Dim match_count As Integer
Dim list_multiplier As Integer
list_multiplier = 7
Dim list_row() As Long
ReDim list_row(0)
list_row(0) = 2
For rw = 2 To ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
If ws1.Range("B" & rw).Value <> ws1.Range("B" & rw).Offset(-1, 0).Value Then
match_count = 0
Else
match_count = match_count + 1
End If
Dim list_num As Integer
list_num = match_count \ 3
If list_num > UBound(list_row, 1) Then
ReDim Preserve list_row(list_num)
list_row(list_num) = 2
End If
ws2.Cells(list_row(list_num), 1 + list_multiplier * list_num).Value = ws1.Range("A" & rw).Value
ws2.Cells(list_row(list_num), 2 + list_multiplier * list_num).Value = ws1.Range("B" & rw).Value
ws2.Cells(list_row(list_num), 3 + list_multiplier * list_num).Value = ws1.Range("C" & rw).Value
ws2.Cells(list_row(list_num), 4 + list_multiplier * list_num).Value = ws1.Range("D" & rw).Value
ws2.Cells(list_row(list_num), 5 + list_multiplier * list_num).Value = ws1.Range("E" & rw).Value
list_row(list_num) = list_row(list_num) + 1
Next rw
End Sub
When you record your macro, ensure that "Use Relative References" on the Developer Ribbon tab is enabled, :)
assuming row 3 has your data headers, you could try this:
Option Explicit
Sub main()
Dim nLists As Long, iList As Long
Dim data As Variant
Dim dataToDelete As Range
With Range("F3", Cells(Rows.Count, 1).End(xlUp))
data = .Value
nLists = WorksheetFunction.Max(.Resize(,1))
nLists = nLists \ 3 + IIf(nLists - 3 * (nLists \ 3) = 0, -1, 0)
End With
With Range("A3").Resize(, 6)
For iList = 0 To nLists
Set dataToDelete = Nothing
With .Offset(, iList * 6).Resize(UBound(data))
.Value = data
.AutoFilter Field:=1, Criteria1:="<=" & iList * 3, Criteria2:=">" & (iList + 1) * 3, Operator:=xlOr
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set dataToDelete = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.AutoFilterMode = False
If Not dataToDelete Is Nothing Then dataToDelete.Delete xlShiftUp
End With
Next
End With
End Sub
Your task is actually slightly trickier than your online advice suggests. Basically, you have to do the following:
Find out how many unique 'keys' (ie unique items in column B) you have. This will tell you the total number of rows you need (ie number of unique keys * 3)
Count the number of items for each 'key'. This will tell you how many columns you need (ie max item count / 3 * number of columns in array [A:E = 5])
Loop through each line of data and it put on appropriate row for that 'key'. Once three has been reached, jump the column for that key 6 columns to the right, and continue.
If you were to use a Class object and Collection type of object, this could be really quite concise code, but judging by your post you are at the beginning of your programming journey in VBA. Therefore, I've broken down each task into separate chunks of code so you will hopefully see how arrays can work for you. Once you practise with arrays a little, perhaps you could have a go at making this code more efficient by combining some of the loops:
Public Sub RunMe()
Dim data As Variant
Dim r As Long, c As Long, i As Long, dataRows As Long, dataCols As Long, keyLen As Long, maxCount As Long
Dim keys As String
Dim k As Variant
Dim keyArray() As String
Dim keyCount() As Long, threeCount() As Long, rowNum() As Long, colNum() As Long
Dim output() As Variant
'Read the data - change "Sheet1" to your sheet name.
'Shows how to write range values into a variant to
'create an array of variants.
data = ThisWorkbook.Worksheets("Sheet1").UsedRange.Value2
dataRows = UBound(data, 1)
dataCols = UBound(data, 2)
'Create a list of unique keys.
'Note: not the most efficient way, but shows how to
'create an array from a value-separated string.
For r = 1 To dataRows
If InStr(keys, CStr(data(r, 2))) = 0 Then
If Len(keys) > 0 Then keys = keys & "|"
keys = keys & CStr(data(r, 2))
End If
Next
keyArray = Split(keys, "|")
keyLen = UBound(keyArray)
'Initialise the row and column numbers for each key.
'Shows how to iterate an array using For Each loop.
ReDim rowNum(keyLen)
ReDim colNum(keyLen)
r = 1
i = 0
For Each k In keyArray
rowNum(i) = r
colNum(i) = 1
r = r + 3
i = i + 1
Next
'Count the number of items for each key.
'Shows how to iterate an array using For [index] loop.
ReDim keyCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
keyCount(i) = keyCount(i) + 1
If keyCount(i) > maxCount Then maxCount = keyCount(i)
Next
'Size the output array.
c = WorksheetFunction.Ceiling(maxCount / 3, 1)
ReDim output(1 To (keyLen + 1) * 3, 1 To c * dataCols + c - 1)
'Populate the output array.
ReDim threeCount(keyLen)
For r = 1 To dataRows
i = IndexOfKey(keyArray, CStr(data(r, 2)))
'Copy the columns for this row.
For c = 1 To dataCols
output(rowNum(i), colNum(i) + c - 1) = data(r, c)
Next
'Increment the count and if it's equals 3 then
'reset the row num and increase the column number.
threeCount(i) = threeCount(i) + 1
rowNum(i) = rowNum(i) + 1
If threeCount(i) = 3 Then
rowNum(i) = rowNum(i) - 3
colNum(i) = colNum(i) + dataCols + 1
threeCount(i) = 0
End If
Next
'Write the data - change "Sheet2" to your sheet name.
'Shows how to write an array to a Range.
ThisWorkbook.Worksheets("Sheet2").Range("A3") _
.Resize(UBound(output, 1), UBound(output, 2)).Value = output
End Sub
Private Function IndexOfKey(list() As String, key As String) As Long
Dim i As Long
Dim k As Variant
'Helper function to find index position of key in array.
For Each k In list
If key = k Then
IndexOfKey = i
Exit Function
End If
i = i + 1
Next
IndexOfKey = -1
End Function
I have a big spreadsheet I parse into other spreadsheets. I have something working, albeit slowly.
I read that using arrays is a better approach.
How do I grab certain rows from the main array and insert them into another array to copy into a target sheet at the end?
Here are the original, working functions:
Private Function CopyValues(rngSource As Range, rngTarget As Range)
rngTarget.Resize(rngSource.Rows.Count, rngSource.Columns.Count).Value = rngSource.Value
End Function
Private Function RESORT(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
Set i = Sheets(FROMSHEET)
Set e = Sheets(TOSHEET)
Dim d
Dim j
Dim q
d = 1
j = 2
e.Select
Cells.Select
Selection.Clear
i.Select
Rows(1).Copy
e.Select
Rows(1).PasteSpecial
Do Until IsEmpty(i.Range("G" & j))
If i.Range(Column & j) = "Total" Then
i.Select
Rows(j).Copy
e.Select
Rows(2).PasteSpecial
' CopyValues i.Rows(j), e.Rows(2)
Exit Do
End If
j = j + 1
Loop
d = 2
j = 2
Do Until IsEmpty(i.Range("G" & j))
If i.Range(Column & j) = TOSHEET Or i.Range(Column & j) = EXTRA1 Or i.Range(Column & j) = EXTRA2 Or i.Range(Column & j) = EXTRA3 Then
d = d + 1
CopyValues i.Range(i.Cells(j, 1), i.Cells(j, 11)), e.Range(e.Cells(d, 1), e.Cells(d, 11)) 'e.Range("A" & d)
ElseIf i.Range("A" & j) = e.Range("A" & d) And i.Range("I" & j) = "Total" Then
d = d + 1
e.Select
Rows(2).Copy
Rows(d).PasteSpecial
' CopyValues e.Rows(2), e.Rows(d)
End If
j = j + 1
Loop
e.Select
Rows(2).Delete
Range("A1").Select
End Function
Here's what I'm hacking on, many different attempts in there:
Private Function RESORT2(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
' Set i = Sheets(FROMSHEET)
' Set e = Sheets(TOSHEET)
Dim d
Dim j As Long
Dim i As Long
Dim k As Long
Dim myarray As Variant
Dim arrTO As Variant
d = 1
j = 1
'myarray = Worksheets(FROMSHEET).Range("a1").Resize(10, 20)
myarray = Worksheets(FROMSHEET).Range("a1:z220").Value 'Resize(10, 20)
For i = 1 To UBound(myarray)
If myarray(i, 9) = TOSHEET Then
'arrTO = myarray
' Worksheets(TOSHEET).Range("A" & j).Resize(1, 20) = Application.WorksheetFunction.Transpose(myarray(i))
Worksheets(TOSHEET).Range("A" & j).Value = Application.WorksheetFunction.Transpose(myarray)
' arrTO = j 'Application.WorksheetFunction.Index(myarray, 0, 1)
j = j + 1
End If
Next
Worksheets(TOSHEET).Range("a1").Resize(10, 20) = arrTO
End Function
First Edit
I tried cleaning up:
Private Function RESORT(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
Set FRO = Sheets(FROMSHEET)
Set TOO = Sheets(TOSHEET)
Dim TOO_IND
Dim FRO_IND
Dim TotalRow
TotalRow = 2
TOO_IND = 2
FRO_IND = 2
TOO.Cells.Clear
TOO.Rows(1).Value = FRO.Rows(1).Value
Do Until IsEmpty(FRO.Range("G" & TotalRow))
If FRO.Range(Column & TotalRow) = "Total" Then
FRO.Select
Rows(TotalRow).Copy
TOO.Select
Rows(2).PasteSpecial
' CopyValues FRO.Rows(j), TOO.Rows(2)
Exit Do
End If
TotalRow = TotalRow + 1
Loop
Do Until IsEmpty(FRO.Range("G" & FRO_IND))
If FRO.Range(Column & FRO_IND) = TOSHEET Or FRO.Range(Column & FRO_IND) = EXTRA1 Or FRO.Range(Column & FRO_IND) = EXTRA2 Or FRO.Range(Column & FRO_IND) = EXTRA3 Then
TOO_IND = TOO_IND + 1
TOO.Rows(TOO_IND).Value = FRO.Rows(FRO_IND).Value
ElseIf FRO.Range("A" & FRO_IND) = TOO.Range("A" & TOO_IND) And FRO.Range("I" & FRO_IND) = "Total" Then
TOO_IND = TOO_IND + 1
TOO.Select
Rows(2).Copy
Rows(TOO_IND).PasteSpecial
' TOO.Rows(TOO_IND).PasteSpecial = FRO.Rows(2).PasteSpecial ' this isn't working, I need format and formula, if I just do .formula it doesn't work
End If
FRO_IND = FRO_IND + 1
Loop
TOO.Rows(2).Delete
'Range("A1").Select
End Function
It's slower (3.2s vs. 2.86s on my smallest sample set).
I think the array is going to be the solution. I run this routine multiple times on the same sample set, but with different qualifiers, if in the main I dump the sample set into an array, then pass this array to this sort routine, I think it'll be faster. I'm still do not know how to do my operations on arrays, specifically copying one row from array to array.
Second Edit
I'm much closer now! What once took ~133 seconds, now only takes 10.51 seconds!
I'm still trying to trim up some time. I have not yet coded anything to grab the array once and then pass the array to the RESORT function, I'm looking into that next to see if that will help speed things up.
Is there a way to copy the formula and the value into the same array? I don't like the way I do it, but it does work.
Private Function RESORT(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
Set FRO = Sheets(FROMSHEET)
Set TOO = Sheets(TOSHEET)
Dim TotalRow
TotalRow = 2
TOO_IND = 2
FRO_IND = 2
Dim Col As Long
Dim FROM_Row As Long
Dim TO_Row As Long
Const NumCol = 25
Dim myarray As Variant
Dim myarrayform As Variant
Dim arrTO(1 To 1000, 1 To 2000)
Dim arrTotal(1 To 1, 1 To NumCol)
TO_Row = 2
myarray = Worksheets(FROMSHEET).Range("a1:z1000").Value
myarrayform = Worksheets(FROMSHEET).Range("a1:z1000").FormulaR1C1
TOO.Cells.Clear
For Col = 1 To NumCol
arrTO(1, Col) = myarray(1, Col)
Next
For FROM_Row = 1 To UBound(myarray)
If myarray(FROM_Row, Column) = "Total" Then
For Col = 1 To NumCol
arrTotal(1, Col) = myarrayform(FROM_Row, Col)
Next
Exit For
End If
Next
For FROM_Row = 1 To UBound(myarray)
If myarray(FROM_Row, Column) = TOSHEET Or myarray(FROM_Row, Column) = EXTRA1 Or myarray(FROM_Row, Column) = EXTRA2 Or myarray(FROM_Row, Column) = EXTRA3 Then
For Col = 1 To NumCol
arrTO(TO_Row, Col) = myarray(FROM_Row, Col)
Next
TO_Row = TO_Row + 1
ElseIf myarray(FROM_Row, 1) = arrTO(TO_Row - 1, 1) And myarray(FROM_Row, Column) = "Total" Then
For Col = 1 To NumCol
arrTO(TO_Row, Col) = arrTotal(1, Col)
Next
TO_Row = TO_Row + 1
End If
Next
Worksheets(TOSHEET).Range("a1").Resize(1000, 2000) = arrTO
End Function
Iterating over arrays in VBA will not necessarily be faster than iterating over the collection objects that your first method uses. The collections are likely implemented as linked lists, so for the purpose of starting at the beginning and looping over them, they will be equally as speedy as arrays.
The high-level answer is that your sort algorithm will usually be vastly more important than your specific code details. That is, as long as your details don't somehow increase the complexity of running that algorithm.
In my experience, the best way to speed up VBA is to eschew all functions that have an effect on the UI. If your code moves around the selected cell, or switches the actively viewed sheet, etc, that is the biggest timesink. I think those functions Select, Copy(), and PasteSpecial() might be guilty of that. It would be better to store worksheet and range objects, and write directly to their cells as required. You do that in your 2nd method, and I think it is much more important than changing your data type.
I agree with #Seth Battin, but have a few additional things to add.
While arrays can be faster, if you need to search them they do not scale well. The code you have written will iterate through your dataset n times (where n is the number of TOSHEETs you have). Also your code is writing data to the worksheet once for each row (which is time consuming), It is faster (but more code) to put all the data into a single 2D array and write once.
A better program flow might be
Read each line of data
Assign it to a data structure (I would use a scripting dictionary containing 2D arrays)
After all the data is read iterate the scripting dictionary outputting each 2D array
This will minimize both reads and writes to the spreadsheet which is where the preformance bottlenecks are for this type of vba program.
Yes. You would definitely speed up your code by using arrays instead of collections of cells. This is because accessing the properties of the objects takes time.
Honestly though, your code would likely not benefit very much from using arrays as your code is more reasonably modified by eliminating unnecessary loops.
I've re-written the beginning of your RESORT function in a more Excel centric way avoiding some of the pitfalls like selects. I'd also suggest trying to use variable names that are meaningful, especially for objects.
OPTION EXPLICIT
Private Function RESORT(FROMSHEET As Variant, Column As Variant, TOSHEET As Variant, EXTRA1 As Variant, EXTRA2 As Variant, EXTRA3 As Variant)
'Actually indicate variable types.
dim i as worksheet, dim e as worksheet
dim searchRange as Range
Set i = Sheets(FROMSHEET)
Set e = Sheets(TOSHEET)
Dim d as long
Dim j as long
dim lastRow as long 'Using a meaningful variable name
d = 1
j = 2
'I'm assuming you were using PasteSpecial because you only want values.
'I removed your unnecessary selects
e.Cells.Clear
'Move values directly instead of copy paste
i.Rows(1).value = e.Rows(1).value
'Check the first range
If Not IsEmpty(.Range("G" & j)) Then
'Determine the last row to check.
'This would break if j is equivalent to the last possible row...
'but only an example
If IsEmpty(.Range("G" & j+1) then
lastRow = j
else
lastrow = i.Range("G" & j).End(xlDown).Row
end if
'Get the search Range
'We might have used arrays here but it's less complicated to
' use built in functions.
Set searchRange = i.Range(i.Range(Column & j), _
i.Range(Column, lastrow).Find("Total"))
If Not (searchRange Is Nothing) Then
'Copy the values of the found row.
e.Rows(2).value = searchRange.EntireRow.value
End If
End If
After doing that I realize that the part that might more reasonably use arrays is after where I stopped. If you want to use arrays here, what you need to do is effectively copy all of the relevant area to an array and then reference the array the same way that you would reference cells.
For Example:
myArray = i.Range("A1:B10")
MsgBox myArray(10, 2) 'Displays value of B10 (10th row, 2nd column)
MsgBox i.Cells(10, 2) 'Displays value of B10 (10th row, 2nd column)