I am pretty new with arrays in VBA, and need some help finishing a code...
The objective is to copy from one array to another if a value in the first part of the array is found.
Here's what I have so far, and I have put comments in the lines that I am struggling with.
Option Explicit
Sub ReadingRange()
Dim ARRAY_Multiwage As Variant
Dim ARRAY_TEMP_Multiwage() As Variant
ARRAY_Multiwage = Sheets("Multiwage").Range("A1").CurrentRegion
Dim a As Long
Dim b As Long
For a = LBound(ARRAY_Multiwage, 1) To UBound(ARRAY_Multiwage, 1)
If ARRAY_Multiwage(a, 1) = "60021184_2018/36/HE" Then
'add ARRAY_Multiwage(a, 1) to ARRAY_TEMP_Multiwage
'Debug print to see that it has been added
Else:
End If
Next a
End Sub
Any help would be greatly appreciated
Try this out. What you are looking for is ReDim option to dynamically expand an array before entering data into the newest slot.
Sub ReadingRange()
Dim ARRAY_Multiwage As Variant
Dim ARRAY_TEMP_Multiwage() As String
ARRAY_Multiwage = Sheets("Sheet2").Range("A1").CurrentRegion
Dim a As Long
Dim b As Long
' c is the counter that helps array become larger dynamically
Dim c As Long
c = 0
For a = LBound(ARRAY_Multiwage, 1) To UBound(ARRAY_Multiwage, 1)
If ARRAY_Multiwage(a, 1) = "60021184_2018/36/HE" Then
' change the dimension of the array
ReDim Preserve ARRAY_TEMP_Multiwage(c)
' add data to it
ARRAY_TEMP_Multiwage(c) = ARRAY_Multiwage(a, 1)
' print what was added
Debug.Print ("Ubound is " & UBound(ARRAY_TEMP_Multiwage) & ". Latest item in array is " & ARRAY_TEMP_Multiwage(UBound(ARRAY_TEMP_Multiwage)))
' get ready to expand the array
c = c + 1
Else:
End If
Next a
End Sub
I tend to use a Long data type variable as a counter within the loop for the destination array, that way each time the array is accessed, a new element can be written to. In past I've been steered towards declaring the new array with the maximum upper bound it could hold and resize it once at the end so the below example will follow that.
Option Explicit
Sub ReadingRange()
Dim ARRAY_Multiwage As Variant
Dim ARRAY_TEMP_Multiwage() As Variant
ARRAY_Multiwage = Sheets("Multiwage").Range("A1").CurrentRegion
Dim a As Long
Dim b As Long
Dim ArrayCounter as Long
ArrayCounter = 1 'Or 0, depends on if you are using a zero based array or not
For a = LBound(ARRAY_Multiwage, 1) To UBound(ARRAY_Multiwage, 1)
If ARRAY_Multiwage(a, 1) = "60021184_2018/36/HE" Then
ARRAY_TEMP_Multiwage(ArrayCounter) = ARRAY_Multiwage(a, 1)
Debug.Print ARRAY_TEMP_Multiwage(ArrayCounter)
ArrayCounter = ArrayCounter + 1
Else
'Do nothing
End If
Next a
ReDim Preserve ARRAY_TEMP_Multiwage (1 To (ArrayCounter - 1))
End Sub
Copy Range With Criteria
The following will copy from worksheet Sourceultiwage to worksheet
Targetultiwage both in ThisWorkbook, the workbook containing this
code.
Adjust the values in the constants section including wb.
Additionally you can choose to copy headers (copyHeaders)
The Code
Option Explicit
Sub copyWithCriteria()
' Source
Const srcName As String = "Sourceultiwage"
Const srcFirst As String = "A1"
' Target
Const tgtName As String = "Targetultiwage"
Const tgtFirst As String = "A1"
' Criteria
Const CriteriaColumn As Long = 1
Const Criteria As String = "60021184_2018/36/HE"
' Headers
Const copyHeaders As Boolean = False
' Workboook
Dim wb As Workbook: Set wb = ThisWorkbook
' Write values from Source Range to Source Array.
Dim rng As Range
Set rng = wb.Worksheets(srcName).Range(srcFirst).CurrentRegion
Dim NoR As Long
NoR = WorksheetFunction.CountIf(rng.Columns(CriteriaColumn), Criteria)
Dim Source As Variant: Source = rng.Value
' Write values from Headers Range to Headers Array.
If copyHeaders Then
Dim Headers As Variant: Headers = rng.Rows(1).Value
End If
' Write from Source to Target Array.
Set rng = Nothing
Dim UB1 As Long: UB1 = UBound(Source)
Dim UB2 As Long: UB2 = UBound(Source, 2)
Dim Target As Variant: ReDim Target(1 To NoR, 1 To UB2)
Dim i As Long, j As Long, k As Long
For i = 1 To UB1
If Source(i, CriteriaColumn) = Criteria Then
k = k + 1
For j = 1 To UB2
Target(k, j) = Source(i, j)
Next j
End If
Next i
' Write from Target Array to Target Range.
With wb.Worksheets(tgtName).Range(tgtFirst)
If copyHeaders Then .Resize(, UB2).Value = Headers ' Headers
.Offset(Abs(copyHeaders)).Resize(NoR, UB2).Value = Target ' Data
End With
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
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.
I am trying to assign an array to a range of values in an Excel sheet.
When I do though, even though using debug the array is not all zeros, it returns all zeros.
The weird thing is for the dat1 variable it does write to the cells correctly. Though that along with dat2 is an array of strings.
Thanks in advance.
Sub Comparor()
Dim dat1() As Variant
Dim dat2() As Variant
dat1() = Sheets("Data1").Range("E1:E10").Value2
dat2() = Sheets("Data2").Range("E1:E10").Value2
Dim iTemp As Integer
iTemp = CInt(UBound(dat1))
Dim NumMatches() As Integer
ReDim NumMatches(iTemp)
Dim iNum As Integer
Dim iCompareInner As Integer 'dat 2 cycler
Dim iCompareOuter As Integer 'dat 1 cycler
For iCompareOuter = 1 To UBound(dat1)
For iCompareInner = 1 To UBound(dat2)
If (dat1(iCompareOuter, 1) = dat2(iCompareInner, 1)) Then
NumMatches(iCompareOuter) = NumMatches(iCompareOuter) + 1
End If
Next iCompareInner
Next iCompareOuter
Dim test22(10, 1) As Integer
For iNum = 1 To UBound(NumMatches)
'Debug.Print NumMatches(iNum)
test22(iNum, 1) = NumMatches(iNum)
Debug.Print test22(iNum, 1)
Next iNum
Sheets("Info").Range("E1:E10").Value2 = dat1
Sheets("Info").Range("F1:F10").Value2 = test22
Sheets("Info").Range("G1:G10").Value2 = NumMatches
End Sub
Count Matches (Dictionary, CountIf, Array (Double-Loop))
All three solutions do the same thing.
Using them with some serious data, e.g. 1K uniques on 100K values (means e.g. 100M iterations in the array version) will reveal the efficiency of each code.
But this is more about 2D one-based (one-column) arrays commonly used with (one-column) ranges.
The code is basic i.e. no blanks or error values are expected and each range has at least 2 cells
(i.e. Data = rg.Value with one cell doesn't work).
Option Explicit
Sub ComparorDictionary()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Read values (duplicates)
Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
Dim vData() As Variant: vData = vws.Range("E1:E10").Value
Dim vrCount As Long: vrCount = UBound(vData, 1)
' Count matches using a dictionary.
Dim vDict As Object: Set vDict = CreateObject("Scripting.Dictionary")
vDict.CompareMode = vbTextCompare
Dim vr As Long
For vr = 1 To vrCount
vDict(vData(vr, 1)) = vDict(vData(vr, 1)) + 1
Next vr
Erase vData ' values data is counted in the dictionary
' Read uniques (no duplicates).
Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
Dim uData() As Variant: uData = uws.Range("E1:E10").Value
Dim urCount As Long: urCount = UBound(uData, 1)
' Write count.
Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
Dim ur As Long
For ur = 1 To urCount
If vDict.Exists(uData(ur, 1)) Then
uMatches(ur, 1) = vDict(uData(ur, 1))
End If
Next ur
Set vDict = Nothing ' data is in the unique arrays
' Write result.
Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
dws.Range("E1").Resize(urCount).Value = uData
dws.Range("F1").Resize(urCount).Value = uMatches
End Sub
Sub ComparorCountIf()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference values (duplicates). No array is needed.
Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
Dim vrg As Range: Set vrg = vws.Range("E1:E10")
' Read uniques (no duplicates).
Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
Dim uData() As Variant: uData = uws.Range("E1:E10").Value
Dim urCount As Long: urCount = UBound(uData, 1)
' Count matches and write the count.
Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
Dim ur As Long
For ur = 1 To urCount
uMatches(ur, 1) = Application.CountIf(vrg, uData(ur, 1))
Next ur
' Write result.
Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
dws.Range("E1").Resize(urCount).Value = uData
dws.Range("F1").Resize(urCount).Value = uMatches
End Sub
Sub ComparorArray()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Read values (duplicates).
Dim vws As Worksheet: Set vws = wb.Worksheets("Data2")
Dim vData() As Variant: vData = vws.Range("E1:E10").Value
Dim vrCount As Long: vrCount = UBound(vData, 1)
' Read uniques (no duplicates).
Dim uws As Worksheet: Set uws = wb.Worksheets("Data1")
Dim uData() As Variant: uData = uws.Range("E1:E10").Value
Dim urCount As Long: urCount = UBound(uData, 1)
' Count matches and write the count.
Dim uMatches() As Long: ReDim uMatches(1 To urCount, 1 To 1)
Dim vr As Long
Dim ur As Long
For ur = 1 To urCount
For vr = 1 To vrCount
If uData(ur, 1) = vData(vr, 1) Then
uMatches(ur, 1) = uMatches(ur, 1) + 1
End If
Next vr
Next ur
Erase vData ' data is in the unique arrays
' Write result.
Dim dws As Worksheet: Set dws = wb.Worksheets("Info")
dws.Range("E1").Resize(urCount).Value = uData
dws.Range("F1").Resize(urCount).Value = uMatches
End Sub
As I said in my comment, one of your declarations is wrong and because of that, the unexpected result. Please, try understanding the next (didactic) code, to clarify the issue:
Sub testArray1D2D()
Dim arr1D, arr2DStrange, arr2D, i As Long
arr1D = Split("a,b,c,d,e,f,g,h,i,j", ",")
ReDim arr2DStrange(10, 1): ReDim arr2D(1 To 10, 1 To 1)
For i = 0 To UBound(arr1D)
arr2DStrange(i, 1) = arr1D(i)
arr2D(i + 1, 1) = arr1D(i)
Next i
Range("A2").Resize(UBound(arr2DStrange), 1).value = arr2DStrange 'it returns nothing
Range("B2").Resize(UBound(arr2DStrange), 2).value = arr2DStrange 'it returns what you need in the second column (D:D)
Range("D2").Resize(UBound(arr2D), 1).value = arr2D 'it returns correctly (what you need)
Range("E2").Resize(UBound(arr1D) + 1, 1).value = Application.Transpose(arr1D) 'also correct (a 1D array does not have any column! and it must be transposed. Otherwise, it repeats its first element value)
End Sub
When use declaration Dim test22(10, 1) As Integer it creates a 2D array but it has two columns. It is the equivalent of Dim test22(0 to 10, 0 to 1) As Integer. When you fill only the second column (1) and try returning the first one (0), this column, is empty.
The correct declaration for obtaining a 2D array with 10 rows and 1 column should be Dim test22(1 to 10, 1 to 1) As Integer.
Then, iTemp = CInt(UBound(dat1)) declares a 1D array of 11 elements (from 0, inclusive, to 10). And you never loaded its first element, starting iteration with 1. That's why the line Sheets("Info").Range("G1:G10").Value2 = NumMatches returned the first empty element 10 times... If your code would fill correctly the first element and if it was a matching one, your code will return 10 rows of 1 value.
NumMatches(iCompareOuter) = NumMatches(iCompareOuter) + 1 is the equivalent of NumMatches(iCompareOuter) = 1. NumMatches(iCompareOuter) is always empty in that moment...
And it is good to cultivate the habit to avoid declarations As Integer in such a case. Working with Excel rows, the value of an Integer must be exceeded. Try using As Long. VBA is so designed to make the memory working in the same way, without any supplementary stress.
A more compact way to accomplish what you need will be the next approach:
Sub Comparor()
Dim dat1(), dat2(), NumMatches(), mtch, i As Long
dat1() = Sheets("Data1").Range("E1:E10").Value2
dat2() = Sheets("Data2").Range("E1:E10").Value2
ReDim NumMatches(1 To UBound(dat1), 1 To 1)
For i = 1 To UBound(dat1)
mtch = Application.match(dat1(i, 1), dat2, 0)
If IsNumeric(mtch) Then NumMatches(i, 1) = "OK"
Next i
Sheets("Info").Range("G1:G10").Value2 = NumMatches
End Sub
Not tested, but it should work. Except the case of a typo, when an error will be raised and sending some feedback I will rapidly correct...
This for example
Dim test22(10, 1) As Integer
in the absence of Option Base 1 is the same as
Dim test22(0 to 10, 0 to 1) As Integer
I'd use
Dim test22(1 to 10, 1 to 1) As Integer
if you want to match the arrays you read from the worksheet. Otherwise, dropping those arrays to a range only gives you the first "column" (which are all zeros since you never assigned anything there...)
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
This is a follow up question to my previous VBA question. Someone provided me with a potential solution for a lag in performance, and mentioned instead of looping through the actual cells in each column, transform the columns into Arrays and then load the results into a new Array.
I keep getting "subscript out of range" issues, among other various errors. I've manipulated these Arrays so many times with ReDim and others to try to load the results, but I keep hitting the same issue. You will see some of the code I tried where things are commented out.
How can I properly load these results based on the information I have? I thought at first it was because I was declaring a dynamic, empty Array, so that's why I used the UBound of an array of the same size in a ReDim.
Sub Missing_CAT():
Dim i As Variant
Dim j As Variant
'Dim j As Long
'Dim h As Long
'Dim h As Variant
Dim d As Date
Dim e As Date
Dim f As Date
Dim a As String
Dim ws As Worksheet
Dim rowCount As Long
Dim secondRowCount As Long
Dim oDateArr() As Variant
Dim fromDateArr() As Variant
Dim toDateArr() As Variant
Dim perilArr() As Variant
Dim resultArr() As Variant
Dim cell As Variant
Dim counter As Variant
Dim count As Long
Dim boundary As Long
Dim ub As Integer
rowCount = Worksheets("raw_data_YOA").Cells(Rows.count, "A").End(xlUp).row
oDateArr = Sheets("raw_data_YOA").Range("Q2:Q" & rowCount).Value
ub = UBound(oDateArr)
ReDim resultArr(ub)
count = 0
'For i = 2 To rowCount
For Each i In oDateArr
'd = Worksheets("raw_data_YOA").Cells(i, 17).Value
d = i
For Each ws In Sheets
If ws.Name = "2020" Or ws.Name = "2019" Then
secondRowCount = ws.Cells(Rows.count, "D").End(xlUp).row
fromDateArr = ws.Range("D5:D" & secondRowCount).Value
toDateArr = ws.Range("E5:E" & secondRowCount).Value
perilArr = ws.Range("F5:F" & secondRowCount).Value
' For j = 5 to secondRowCount
'For Each j In fromDateArr
'boundary = UBound(fromDateArr)
For j = 1 To UBound(fromDateArr)
' MsgBox (fromDateArr(j))
e = fromDateArr(j, 1)
f = toDateArr(j, 1)
p = perilArr(j, 1)
'e = ws.Cells(j, 4).Value
' f = ws.Cells(j, 5).Value
If d >= e And d <= f Then
' ReDim Preserve resultArr(1 To UBound(resultArr) + 1)
' resultArr(UBound(resultArr), 1) = p
resultArr(count) = p
Exit For
ElseIf j = UBound(fromDateArr) Then
' Worksheets("raw_data_YOA").Cells(i, 63).Value = "FALSE"
' ReDim Preserve resultArr(1 To UBound(resultArr) + 1)
' MsgBox (UBound(resultArr))
resultArr(count) = "FALSE"
End If
Next j
Else
GoTo NextIteration
End If
count = count + 1
NextIteration:
Next
Next i
counter = 0
For Each cell In Sheets("raw_data_YOA").Range("Q2:Q" & rowCount)
cell.Value = resultArr(counter)
counter = counter + 1
Next
MsgBox ("Done")
End Sub
EDIT:
Specifically, the lines throwing the errors are resultArr(count) = ...
I'm trying to copy worksheets from a master workbook to a target workbook but the sheets that I copy are different depending on if the value in rngCurrent is present in the worksheet name. For some reason I keep getting a subscript out or range error on the last line. Can anyone help me understand what's going on?
Sub test2()
Dim wb As Workbook
Dim master As Workbook
Dim wbCurrent As Workbook
Dim wbAdjustments As Workbook
Dim wsName As Worksheet
Dim rngEntityList As Range
Dim rngCurrentEntity As Range
Dim rngCurrent As Range
Dim arrWorksheets As Variant
Dim i As Integer
Dim wsCount As Integer
Set master = ThisWorkbook
Set rngCurrentEntity = master.Sheets("File Info").Range("rng_Entity") 'named range of single entity
Set rngEntityList = master.Sheets("Global").Range("rng_EntityList") 'list or entities
Set rngCurrent = rngEntityList.Find(rngCurrentEntity.Value, LookIn:=xlValues) ' find single entity in the list
If rngCurrent.Offset(, 4).Value = "FRP" Then 'find if it's FRP
Set wb = Application.Workbooks("Foreign.xlsx")
Else
Set wb = Application.Workbooks("Domestic.xlsx")
End If
Dim ws() As String ' declare string array
ReDim ws(wb.Worksheets.Count) As String ' set size dynamically
Dim counter As Long ' running counter for ws array
counter = 1
For i = 1 To wb.Worksheets.Count
If InStr(1, wb.Worksheets(i).Name, rngCurrent.Value) <> 0 Then
ws(counter) = wb.Worksheets(i).Name
counter = counter + 1
End If
Next
ReDim Preserve ws(counter) As String ' Get rid of empty array entries
wb.Worksheets(ws).Copy After:=master.Worksheets(master.Worksheets.Count)
End Sub
EDIT
The reason I need to do it this way is because I don't want the external links to the source notebook.
Complete and tested example
Sub Tester()
Dim wb As Workbook, i As Long
Set wb = ThisWorkbook
Dim ws() As String ' declare string array
ReDim ws(1 To wb.Worksheets.Count) As String ' set size dynamically
Dim counter As Long ' running counter for ws array
counter = 0
For i = 1 To wb.Worksheets.Count
If InStr(1, wb.Worksheets(i).Name, "test") <> 0 Then
counter = counter + 1
ws(counter) = wb.Worksheets(i).Name
End If
Next
ReDim Preserve ws(1 To counter)
wb.Worksheets(ws).Copy 'just makes a copy in a new workbook
End Sub
do this:
ReDim ws(1 To wb.Worksheets.count) As String ' set size dynamically, start from 1
Dim counter As Long ' running counter for ws array
For i = 1 To wb.Worksheets.count
If InStr(1, wb.Worksheets(i).name, rngCurrent.Value) <> 0 Then
counter = counter + 1 '<--| update counter
ws(counter) = wb.Worksheets(i).name
End If
Next