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
Related
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 want to run through each cell in a column and if a condition is met place it into the next available array element.
I have the first part but I don't know how to place each element that meets the IF statement criteria into an array and then transpose that array.
Option Explicit
Private Sub Workbook_Open()
Dim StepCheck As Range
Dim ImporterName As Variant
Dim ws As Worksheet
Dim NameRange As Range
Set ws = Workbooks.Open(Filename:="Filepath goes here").Sheets("Sheet1")
For Each StepCheck In ws.Range("F1:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row)
If IsError(StepCheck.Value) Then
If Err.Number <> 0 Then
Err.Clear
On Error GoTo 0
End If
ElseIf StepCheck.Value = "5" Then
ImporterName = StepCheck.Offset(0, -5).Value
End If
Next
End Sub
How do I store every StepCheck when it meets the IF statement criteria into the array importer name?
The code runs but doesn't store all of the StepCheck entries into the array and instead gets overwritten every loop.
Match Data
It will return the values from column A from the rows where the value in column F is equal to 5 in a 1D array and print its contents in the Immediate window.
Option Explicit
Sub MatchData()
' (Open and) Reference the workbook ('wb').
Dim wb As Workbook: Set wb = Workbooks.Open("C:\Test\Test.xlsx")
' For the workbook containing this code, use:
'Dim wb As Workbook: Set wb = ThisWorkbook
' Reference the worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
' Write the values from the source lookup column
' to a 2D one-based one-column array ('slData').
Dim slrg As Range
Set slrg = sws.Range("F1", sws.Cells(sws.Rows.Count, "F").End(xlUp))
Dim srCount As Long: srCount = slrg.Rows.Count
Dim slData() As Variant
If srCount = 1 Then
ReDim slData(1 To 1, 1 To 1): slData(1, 1) = slrg.Value
Else
slData = slrg.Value
End If
' Write the values from the source value column
' to a 2D one-based one-column array ('svData').
Dim svrg As Range: Set svrg = slrg.EntireRow.Columns("A")
Dim svData() As Variant
If srCount = 1 Then
ReDim svData(1 To 1, 1 To 1): svData(1, 1) = svrg.Value
Else
svData = svrg.Value
End If
' Write the required values from the source values array
' to a 1D one-based array ('dArr').
Dim dArr() As Variant: ReDim dArr(1 To srCount) ' too big
Dim sValue As Variant
Dim sr As Long
Dim dc As Long
For sr = 1 To srCount
sValue = slData(sr, 1)
If VarType(sValue) = vbDouble Then ' is a number
If sValue = 5 Then ' is equal to 5
dc = dc + 1
dArr(dc) = svData(sr, 1)
' Else ' is a number but not equal to 5; do nothing
End If
' Else ' is not a number; do nothing
End If
Next sr
' Resize the destination array (remove the trailing 'empties').
ReDim Preserve dArr(1 To dc)
' Print the contents of the array to the Immediate window ('Ctrl+G').
Debug.Print "Index", "Value"
For dc = 1 To UBound(dArr)
Debug.Print dc, dArr(dc)
Next dc
End Sub
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
I have a procedure to create a new sheet based on available data. Basically, it creates a sheet based on the name of the data. The code is written as follows. It does work actually if I assign the procedure one by one.
Sub new_profile(tankname)
Sheets.Add After:=ActiveSheet
Range("B4").Select
ActiveCell.FormulaR1C1 = tankname
ActiveSheet.Name = Range("b4").Value
end sub
Due to the fact that I will use this code for another workbook (which means there is no exact amount of data), I try to assign an array to automatically run the procedure all in one without call it one by one. The code is as follow:
Sub calculate_all()
Dim cel As Range
Dim tank_name() As String
Dim i As Integer, j As Integer
Dim n As Integer
i = 11
n = Range("B6").Value
ReDim tank_name(i)
For Each cel In ActiveSheet.Range(Cells(11, 2), Cells(11 + n, 2))
tank_name(i) = cel.Value
i = i + 1
new_profile tank_name(i)
ReDim Preserve tank_name(i)
Next cel
End Sub
Unfortunately, it becomes error and shows the message "subscript out of range". How could I solve this problem?
For Each Element in Array Run a Procedure
Let's say that creating a new profile means adding a new sheet, renaming it and writing the name to a cell.
The 1st, main procedure createProfiles does the previously mentioned only if a worksheet with the current name in the TankNames array doesn't exist.
The 2nd procedure deleteProfiles deletes all sheets if their names exist in the TankNames array.
The 3rd and the 4th procedure are called by both previously mentioned procedures, while the 5th is obviously only called by the main procedure.
Before running any of the first two procedures, adjust the constants in them to fit your needs.
The Code
Option Explicit
Sub createProfiles()
' Source
Const wsName As String = "Sheet1" ' Tab Name
Const FirstRow As Long = 11
Const NameCol As Variant = "B" ' e.g. 1 or "A", 2 or "B"...
' Target
Const CellAddress As String = "B4"
' Other
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Worksheet.
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Write tank names from Source Worksheet to TankNames array.
Dim TankNames As Variant
getColumn TankNames, ws, NameCol, FirstRow
Dim i As Long
' Loop through elements of TankNames array.
For i = 1 To UBound(TankNames)
' For each tank name create a new profile.
If Not foundSheetName(wb, TankNames(i, 1)) Then
Call createProfile wb, TankNames(i, 1), CellAddress
End If
Next i
End Sub
Sub deleteProfiles()
' Source
Const wsName As String = "Sheet1" ' Tab Name
Const FirstRow As Long = 11
Const NameCol As Variant = "B" ' e.g. 1 or "A", 2 or "B"...
' Other
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Worksheet.
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Write tank names from Source Worksheet to TankNames array.
Dim TankNames As Variant
getColumn TankNames, ws, NameCol, FirstRow
Dim i As Long
' Loop through elements of TankNames array.
For i = 1 To UBound(TankNames)
' For each tank name delete profile (sheet).
If foundSheetName(wb, TankNames(i, 1)) Then
Application.DisplayAlerts = False
wb.Worksheets(TankNames(i, 1)).Delete
Application.DisplayAlerts = True
End If
Next i
End Sub
Sub getColumn(ByRef Data As Variant, _
Sheet As Worksheet, _
Optional ByVal ColumnID As Variant = 1, _
Optional ByVal FirstRow As Long = 1)
Data = Empty
If Sheet Is Nothing Then Exit Sub
Dim rng As Range
Set rng = Sheet.Columns(ColumnID).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set rng = Sheet.Range(Sheet.Cells(FirstRow, ColumnID), rng)
If rng.Cells.Count > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
End If
End Sub
Function foundSheetName(Book As Workbook, _
Optional ByVal SheetName As String = "Sheet1") _
As Boolean
If Book Is Nothing Then Set Book = ActiveWorkbook
On Error Resume Next
Dim ws As Worksheet: Set ws = Book.Worksheets(SheetName)
If Err.Number = 0 Then foundSheetName = True
End Function
Sub createProfile(Book As Workbook, _
ByVal NewName As String, _
ByVal NameCellAddress As String)
Dim ws As Worksheet
Set ws = Book.Worksheets.Add(After:=Book.Sheets(Book.Sheets.Count))
With ws
.Name = NewName
.Range(NameCellAddress) = NewName
End With
End Sub
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