I have a vast list of data in a worksheet (called MainDump). I have a procedure set up to assess this list and return certain values using the following setup:
Dim ws1 As Worksheet
Set ws1 = Worksheets("DashBoard")
Dim ws2 As Worksheet
Set ws2 = Worksheets("MainDump")
Dim cntr As Long
On Error GoTo ErrorHandler 'Got A lot of divide by zero errors if searchstring wasn't found
With Application.WorksheetFunction
ws1.Range("O4").Value = .CountIf(ws2.Range("E:E"), "*" & "CEOD" & "*")
ws1.Range("L4").Value = .CountIfs(ws2.Range("E:E"), "*" & "CEOD" & "*", ws2.Range("A:A"), "Yes") / ws1.Range("O4").Value
ws1.Range("M4").Value = .CountIfs(ws2.Range("E:E"), "*" & "CEOD" & "*", ws2.Range("B:B"), "Yes") / ws1.Range("O4").Value
ws1.Range("N4").Value = .CountIfs(ws2.Range("E:E"), "*" & "CEOD" & "*", ws2.Range("C:C"), "SA Present, WBDA Present") / ws1.Range("O4").Value
End With
cntr = cntr + 1
'^This proces is then copied and thus repeated a total of 76 times, as I want to check
'for 76 different values in ws2.Range("E:E"), resulting in a massive code
ErrorHandler:
If Err.Number = 6 Then
If ws1.Range("O" & cntr).Value = 0 Then
ws1.Range("L" & cntr).Value = "div. by zero"
ws1.Range("M" & cntr).Value = "div. by zero"
ws1.Range("N" & cntr).Value = "div. by zero"
End If
End If
Resume Next
I wrote this when I was a lot less experienced in VBA. Needless to say this code takes a lot of time to complete (Maindump counts about 98000 rows).
So I wanted to try do this work via an array.
My approach would be to define a counter for each string I want to check in the array indexes and then looping through the array and increment the corresponding counters when a string is found in the Array. My question is if there is a way to write that loop in the following form:
Dim LastRow1 As long
Dim DataArray() As Variant
Dim SearchString1, SearchString2, .... SearchString76 As String
Dim SearchString1Cntr, SearchString2Cntr, .... SearchString76Cntr As long
With ws2
LastRow1 = .Cells.Find(What:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row 'Gets the total row amount in the sheet
DataArray = .Range("A3:E" & LastRow1) 'puts selected range in Array
End With
For LastRow1 = Lbound(DataArray, 1) to Ubound(DataArray, 1)
'Start a For Each loop to check for all 76 strings
If Instr(1, DataArray(LastRow1, 5), SearchString > 0 Then 'SearchString is found so then
SearchStringCntr1 = SearchStringcntr1 + 1
'Where SearchStrinCntr1 is the counter related to the string checked for in the loop,
'so it switches when the SearchString changes
End If
'Next SearchString to check
Next LastRow1
So I want to try and use a flexible If statement in a For Next loop which checks the Array index for each SearchString and then increments the corresponding SearchStringCntr if the SearchString is found in the index, before looping to the next index. Is this possible? I would like to prevent making 76 different If/ElseIf statements for each SearchString + StringCntr and then use a counter to loop through them every time the code loops through the For LastRow1 / Next LastRow1 loop. Would love to hear your input.
Maybe this will help (might need some adjustments).
Create named range "Strings" somewhere in your workbook where you'll store all your strings that you're looking for
Option Explicit
Sub StringsCompare()
Dim LastRow1 As Long
Dim DataArray() As Variant, StringArray() As Variant
Dim Ws2 As Worksheet
Dim CompareStringsNo As Long, StringCounter As Long
Dim i As Long, j As Long
Dim aCell As Range
Dim SourceStr As String, SearchStr As String
Set Ws2 = ThisWorkbook.Sheets("Sheet1")
StringCounter = 1
With Ws2
'fill array with your strings to compare
CompareStringsNo = .Range("Strings").Rows.Count
ReDim StringArray(1 To CompareStringsNo, 1 To 2)
For Each aCell In .Range("Strings")
StringArray(StringCounter, 1) = aCell.Value
StringCounter = StringCounter + 1
Next aCell
'fill data array
LastRow1 = .Cells.Find(What:="*", After:=.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row 'Gets the total row amount in the sheet
DataArray = .Range("A1:E" & LastRow1)
End With
'search data array
For i = LBound(DataArray, 1) To UBound(DataArray, 1)
SourceStr = DataArray(i, 5)
'search array with your strings
For j = LBound(StringArray) To UBound(StringArray)
SearchStr = StringArray(j, 1)
If InStr(1, SourceStr, SearchStr) > 0 Then
'if match is found increase counter in array
StringArray(j, 2) = StringArray(j, 2) + 1
'you can add exit for here if you want only first match
End If
Next j
Next i
For i = LBound(StringArray) To UBound(StringArray)
Debug.Print StringArray(i, 1) & " - " & StringArray(i, 2)
Next i
End Sub
I think the main task is being over-complicated.
To check how many times a string occurs within an array you could use a function like this:
Function OccurWithinArray(theArray As Variant, stringToCount As String) As Long
Dim strArr As String
strArr = Join(theArray, " ")
OccurWithinArray = (Len(strArr) - Len(Replace(strArr, stringToCount, _
vbNullString, , , vbTextCompare))) / Len(stringToCount)
End Function
...and a demonstration:
Sub Demo()
Dim test(1 To 3) As String
test(1) = "I work at the Dog Pound."
test(2) = "I eat dogfish regularly."
test(3) = "Steroidogenesis is a thing."
Debug.Print OccurWithinArray(test, "dog")
End Sub
How it works:
Join joins all the elements of the array into one big string.
Len returns the length of the text.
Replace temporarily replaces the removes all occurrences of the search term.
Len returns the "modified" length of the text.
The difference between the two Len's, divided by the length of the string being searched for, is the number aof occurrences of the string within the entire array.
This returns 3 since the search is case-insensitive.
To make the search case-sensitive, remove the word vbTextCompare (in which case this example would return 2.)
Related
I think i've got a good start, but I'm having a tough time taking this to the finish line. Could someone help me out?
I have a name column(G) in my spreadsheet. I want to pull the only the last name out of each cell and assign it to an array called name_array.
I know that my If function is working because if I set each name_cell to the LastName variable it substitutes only the lastname in each cell of the column, but I cannot figure out how to assign that to the array.
Here is my code thus far. Can someone please help me out and point out what I'm missing?
Sub create_namear()
Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long
Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(name_range.Cells.Count)
For Each name_cell In name_range.Cells
Dim Lastname As String
If InStr(name_cell, " ") > 0 Then
Lastname = Split(name_cell, " ")(1)
End If
name_array(n) = lastname.value
n = n + 1
Next name_cell
Debug.Print name_array(1)
End Sub
Name Column
Here is another way to achieve what you want without looping. I have commented the code so you should not have a problem understanding it.
BASIC LOGIC
To get the part after SPACE, you can use the formula =IFERROR(MID(G2,SEARCH(" ",G2,1),LEN(G2)-SEARCH(" ",G2,1)+1),"")
Now applying the formula in the entire range and getting the value using INDEX(FORMULA). You can find the explanation of this method in Convert an entire range to uppercase without looping through all the cells
CODE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
Dim lRow As Long, i As Long
Dim FinalAr As Variant
'~~> Set this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find last row in col G
lRow = .Range("G" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng = .Range("G2:G" & lRow)
'~~> Get all the last names from the range and store them
'~~> in an array in 1 go!
FinalAr = Evaluate("index(IFERROR(MID(" & _
rng.Address & _
",SEARCH("" ""," & _
rng.Address & _
",1),LEN(" & _
rng.Address & _
")-SEARCH("" ""," & _
rng.Address & _
",1)+1),""""),)")
End With
'~~> Check the output
For i = LBound(FinalAr) To UBound(FinalAr)
Debug.Print ">"; FinalAr(i, 1)
Next i
End Sub
IN ACTION
ALTERNATIVE METHODS
Use Text To columns and then store the output in an array
Use Flash Fill to get the last names and then store the output in an array. One drawback of this method is that the names which do not have last name, it will show first name instead of a blank.
Sub create_namear()
Dim name_array() As Variant
Dim name_range As Range
Dim name_cell As Range
Dim n As Long
Set name_range = ActiveSheet.Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)
ReDim name_array(0 to name_range.Cells.Count-1) '### 0-based array...
For Each name_cell In name_range.Cells
If InStr(name_cell, " ") > 0 Then
name_array(n) = Split(name_cell, " ")(1) 'simplify...
End If
n = n + 1
Next name_cell
Debug.Print name_array(1)
End Sub
Solution using Filter() (values with missing lastnames are excluded):
Sub ExtractLastNames()
Dim arr, name_array, i
arr = WorksheetFunction.Transpose(Range("G2:G" & Cells(Rows.Count, "G").End(xlUp).Row)) 'first, get the horizontal one-dimentional array from cells
name_array = Filter(arr, " ", True) 'second, filter out one-word and empty elements
For i = LBound(name_array) To UBound(name_array)
name_array(i) = Split(name_array(i))(1) 'third, replace name_array values with extracted lastnames
Next
Range("H2").Resize(UBound(name_array) + 1) = WorksheetFunction.Transpose(name_array) ' output
End Sub
Last Names to Array
The following will consider the substring after the last occurring space as the last name.
Option Explicit
Sub create_namear()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim nRange As Range
Set nRange = ws.Range("G2:G" & ws.Range("G" & ws.Rows.Count).End(xlUp).Row)
Dim rCount As Long: rCount = nRange.Rows.Count
Dim nArray() As String: ReDim nArray(0 To rCount - 1)
Dim nCell As Range
Dim n As Long
Dim nmLen As Long
Dim LastSpacePosition As Long
Dim nmString As String
Dim LastName As String
For Each nCell In nRange.Cells
nmString = CStr(nCell.Value)
If InStr(1, nmString, " ") > 0 Then
LastSpacePosition = InStrRev(nCell.Value, " ")
nmLen = Len(nmString)
If LastSpacePosition < nmLen Then
LastName = Right(nmString, nmLen - LastSpacePosition)
nArray(n) = LastName
n = n + 1
End If
End If
Next nCell
If n = 0 Then Exit Sub
If n < rCount Then
ReDim Preserve nArray(0 To n - 1)
End If
Debug.Print "[" & LBound(nArray) & "," & UBound(nArray) & "]" _
& vbLf & Join(nArray, vbLf)
End Sub
Extension on Siddharth' s formula evaluation
These additions to Siddharth's valid code can be helpful, if there are less than 2 data rows in order to avoid
an unwanted evaluation of the title row 1:1 (in case of no data at all, see section 1.b) - This can be prevented by correcting a resulting row number lRow of only 1 to the actual data row start of 2.
Error 9 Subscript out of range (in case of a single element; see section 3.b) - Note that this requires to transform a 1-dim result to a 2-dim results array by means of a adequately dimensioned tmp array.
Furthermore I simplified the formula building to avoid repeated rng.Address insertions just to show another way of doing it (see section 2.).
Sub GetLastName()
'0. Set this to the relevant sheet
Dim ws As Worksheet: Set ws = Sheet1
With ws
'1. Define data range
'1. a) Find last row in col G
Dim lRow As Long
lRow = .Range("G" & .Rows.count).End(xlUp).Row
'1. b) Provide for empty data set ' << Added to avoid title row evaluation
If lRow = 1 Then lRow = 2
'1. c) Set your range
Dim rng As Range: Set rng = .Range("G2:G" & lRow)
'2. Define formula string parts ' << Modified for better readibility
Dim FormulaParts()
FormulaParts = Array("INDEX(IFERROR(MID(", _
",SEARCH("" "",", _
",1),LEN(", _
")-SEARCH("" "",", _
",1)+1),""""),)")
'3. Assign last names to 2-dim array results
'3. a) Get all the last names from the range and store them
Dim results
results = Evaluate(Join(FormulaParts, rng.Address))
End With
'3.b) Provide for single results '<< Added to avoid Error 9 Subscript o/Rng
If UBound(results) = 1 Then '<< Force single element into 2-dim array
Dim tmp(1 To 1, 1 To 1)
tmp(1, 1) = results(1)
results = tmp
End If
'h) Display in VB Editor's immediate window
Dim i As Long
For i = LBound(results) To UBound(results)
Debug.Print ">"; results(i, 1)
Next i
'i) Write last names to target '<< Added to demonstrate writing back
ws.Range("H2").Resize(UBound(results), 1) = results
End Sub
I've got two worksheets. The first (Calculation) contains 10.000 rows with a lot of RTD formulas and different calculations. The second (observer) observes the first one.
I've got a VBA script that runs every second and checks every row of worksheet 1 (Calculation). If the loop finds some marked data on worksheet 1 then it will copy some data from WS1 to WS2.
Solution 1: Loop checking 10.000 rows
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For I = 1 To 10000
If CStr(.Cells(I, 1)) = "X" Then
'DO SOME SUFF (copy the line from WS 1 to WS2)
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Solution 2: Array function with a small loop
Can I use, instead of the 10.000 row loop, an Excel Array to observe the 10.000 rows and do some stuff with the smaller array.
On worksheet 2, I would have this code: (A1:O15)
{=index(Calculation!A$1:$O$10000; .....)....))}
Again I would have a smaller loop through the 15 lines of array function:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For K = 1 To 15
If CStr(.Cells(I, 1)) = "X" Then
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I would like to know what solution has the better performance.
I am not sure if an Excel array over 10.000 rows has a good performance. For sure the 15-rowLoop is faster than a 10000-row-Loop.
I don't know how to measure if a 15-row Loop in connection with an array (observing 10.000 rows) is faster.
Copy to Sheet With Criteria
Copies each row of a dataset in a worksheet containing a specified value (Criteria) in a specified column, to another worksheet.
Adjust the values in the constants section of createReport.
The data transfer will only (always) happen when the worksheet "Observer" is activated e.g. when another sheet is currently selected and the "Observer" tab is clicked on.
This code took about 5 seconds for a million (all) rows, and under a second for 100.000 rows on my machine.
The efficiency can further be improved by using the code with the Worksheet Change event in the "Calculation" worksheet and by turning off certain Application events (e.g. .ScreenUpdating, .Calculation, .EnableEvents).
Excel Test Setup (Worksheet "Calculation")
[A1:I1] ="Column "&COLUMN()
[A2] =IF(I2=1,"X","Y")
[B2:H2] =RANDBETWEEN(1,1000)
[I2] =RANDBETWEEN(1,100)
Sheet Module (Worksheet "Observer")
Option Explicit
Private Sub Worksheet_Activate()
createReport
End Sub
Standard Module e.g. Module1
Option Explicit
Sub createReport()
' Constants
' Source
Const srcName As String = "Calculation"
Const CriteriaColumn As Long = 1
Const Criteria As String = "X"
Const srcFirstCellAddress As String = "A1"
' Target
Const tgtName As String = "Observer"
Const tgtFirstCellAddress As String = "A1"
Const includeHeaders As Boolean = True
' Other
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Range ('rng').
' Define Source First Cell ('cel').
Dim cel As Range
Set cel = wb.Worksheets(srcName).Range(srcFirstCellAddress)
' Define the Current Region ('rng') 'around' First Cell.
Dim rng As Range
Set rng = cel.CurrentRegion
' Define Source Range ('rng') i.e. exclude cells to the left and above
' of Source First Cell from the Current Region.
Set rng = rng.Resize(rng.Rows.Count - cel.Row + rng.Row, _
rng.Columns.Count - cel.Column + rng.Column) _
.Offset(cel.Row - rng.Row, cel.Column - rng.Column)
' Write values from Source Range to Data Array ('Data').
Dim Data As Variant
Data = rng.Value
' Write resulting values from Data Array to Data Array
' i.e. 'shift' them to the beginning.
Dim NoC As Long ' Number of Columns
NoC = UBound(Data, 2)
Dim i As Long ' Source Data Rows Counter
Dim j As Long ' Source/Target Data Columns Counter
Dim CurrentRow As Long ' Target Data Rows Counter
Dim checkHeaders As Long
checkHeaders = -CLng(includeHeaders) ' True is '-1' in VBA.
CurrentRow = checkHeaders
For i = 1 To UBound(Data, 1)
If Data(i, CriteriaColumn) = Criteria Then
CurrentRow = CurrentRow + 1
For j = 1 To NoC
' 'Shift' from 'i' to 'CurrentRow'.
Data(CurrentRow, j) = Data(i, j)
Next j
End If
Next i
' Write values from Data Array to Target Range ('rng').
' Define Target First Cell ('cel').
Set cel = wb.Worksheets(tgtName).Range(tgtFirstCellAddress)
' Define Target First Row ('rng').
Set rng = cel.Resize(, NoC)
' Clear contents in columns.
rng.Resize(rng.Worksheet.Rows.Count - cel.Row + 1).ClearContents
Select Case CurrentRow
Case 0
GoTo CriteriaNotFound
Case checkHeaders
' Write headers from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo CriteriaNotFound
Case Else
' Write values from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo Success
End Select
' Exit.
ProcExit:
Exit Sub
' Inform user.
CriteriaNotFound:
MsgBox "Value '" & Criteria & "' not found.", vbExclamation, "Fail"
GoTo ProcExit
Success:
MsgBox CurrentRow - checkHeaders & " row(s) of data transferred.", _
vbInformation, "Success"
GoTo ProcExit
End Sub
Rather than going back to column A 10,000 times, bring all the values into a 1D VBA array and then loop over that array:
Sub whatever()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = WorksheetFunction.Transpose(rng)
For i = 1 To 10000
If arr(i) = "X" Then
'do some stuff
End If
Next i
End Sub
If there are very few X's then it may be nearly instantaneous.
EDIT#1:
Based on Chris Neilsen's comment, here is a version that does not use Transpose():
Sub whatever2()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = rng
For i = 1 To 10000
If arr(i, 1) = "X" Then
'do some stuff
End If
Next i
End Sub
Test the next code, please. It should be very fast, using arrays and everything happening in memory. The code assumes that you need to copy all occurrences starting with the last empty cell of WS2:
Sub CopyFromWS1ToWs2Array()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, i As Long, k As Long, j As Long
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
k = k + 1 'the array row is incremented (in fact, it is the column now...)
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
End If
Next i
'the final array is Redim, preserving only the existing values:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
LR2 = WS2.cells(rows.count, 1).End(xlUp).row + 1 'last empty row of the second worksheet
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2).Select
MsgBox "Ready...", vbInformation, "Job done"
End Sub
Edited:
Please, test the next code, which should also solve your last requests (as I understood them):
Sub CopyFromWS1ToWs2ArrayBis()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, arrWS2 As Variant
Dim i As Long, k As Long, j As Long, s As Long, boolFound As Boolean
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
LR2 = WS2.cells(rows.count, 1).End(xlUp).row 'last empty row of the second worksheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range of WS1 in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
arrWS2 = WS2.Range("A1:N" & LR2).Value 'put the range of WS2 in an array
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
For s = 1 To UBound(arrWS2)
If arr1(i, 1) = arrWS2(s, 1) And arr1(i, 2) = arrWS2(s, 2) And _
arr1(i, 3) = arrWS2(s, 3) Then
boolFound = True: Exit For 'if first three array columns are the same
End If
Next s
If Not boolFound Then 'if first thrree array columns not the same:
k = k + 1 'the array row is incremented
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
'swap the columns 4 and 5 values:
If arr1(i, 4) = "ABC" And arr1(i, 5) = "XYZ" Then arr2(4, k) = "XYZ": arr2(5, k) = "ABC"
End If
boolFound = False 'reinitialize the boolean variable
End If
Next i
If k > 0 Then
'Preserving only the existing array elements:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2 + 1).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2 + 1).Select
MsgBox "Ready...", vbInformation, "Job done"
Else
MsgBox "No any row to be copied!", vbInformation, "Nothing changed"
End If
End Sub
This question is based on a tip I got in the forum some other day, but since this completely changed the problem I'm creating a new post (it seemed a much better solution than the one I proposed but I'm having some issues).
The rationale of my code is to search up and find entries based on ID in column A (from criteria input in txtbox); if the row matches the search criteria then I want the data from column A to J for that entry to be stored in a dynamic array. All the matching entries will be stored there. This array will be used to display all the relevant entries in a listbox in a userform.
The code is the following:
Private Sub cmdFind_Click()
Dim sht As Worksheet
Dim lastrow As Variant
Dim strSearch As String
Dim aCell As Range
Dim row_number As Integer
Dim item_in_review As Variant
Dim y As Integer
Dim Arr() As Variant
y = lstSearch.ListCount
Set sht = ActiveWorkbook.Sheets("a")
lastrow = sht.Range("A" & Rows.Count).End(xlUp).Row
strSearch = txtSearch.Text
Set aCell = sht.Range("A1:A" & lastrow).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
GoTo wfrefvalid
Else
MsgBox "Oops! That Work File does not exist. Please try again.", Title:="Try again"
txtSearch.Value = ""
End If
Exit Sub
wfrefvalid:
row_number = 0
'clears the listbox so that you have dont have a continuously growing list
lstSearch.Clear
Do
DoEvents
row_number = row_number + 1
ReDim Preserve Arr(item_in_review + 1)
item_in_review = sht.Range("A" & row_number)
If item_in_review = txtSearch.Text Then
Arr = item_in_review.Range("A" & row_number & ":J" & row_number)
End If
Loop Until item_in_review = ""
lstSearch.List = Arr
End Sub
The code isn't giving any debugging-errors, however it's also not doing anything when I press the search button. I think the area where I'm struggling is defining the array, and adding each entry to it as the find-function loops through the table (ie the last 12 or so pieces of code).
ANyone have any tips for adding the data from the search (including the extra columns) to the array?
I think the code would to be like this.
Private Sub cmdFind_Click()
Dim sht As Worksheet
Dim lastrow As Variant
Dim strSearch As String
Dim aCell As Range
Dim row_number As Integer
Dim item_in_review As Variant
Dim y As Integer
Dim Arr() As Variant
Dim rngDB As Range
Dim strAddress As String, n As Long
y = lstSearch.ListCount
Set sht = ActiveWorkbook.Sheets("a")
lastrow = sht.Range("A" & Rows.Count).End(xlUp).Row
Set rngDB = sht.Range("a1", "a" & lastrrow)
strSearch = txtSearch.Text
With rngDB
Set aCell = .Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
strAddress = aCell.Address
Do
n = n + 1
ReDim Preserve Arr(1 To 10, 1 To n)
For i = 1 To 10
Arr(i, n) = aCell(1, i)
Next i
Set aCell = .FindNext(aCell)
Loop While strAddress <> aCell.Address
Else
MsgBox "Oops! That Work File does not exist. Please try again.", Title:="Try again"
txtSearch.Value = ""
End If
End With
If n = 1 Then
lstSearch.List = Arr
ElseIf n > 1 Then
lstSearch.List = WorksheetFunction.Transpose(Arr)
End If
End Sub
I've been searching for an answer to this, but I haven't been able to find anything specific enough to fill the gap in my VBA knowledge.
I'm putting two lists of data into arrays to be compared using a modified version of the code found here
(I'll post it below).
HOWEVER, I don't want to input the whole cell into the array to be compared with the second array. For instance, if the cell in the first sheet says "Company, LLC", I would like to only search "Company". I have some code that does this:
s = rCell.Value
indexofthey = InStr(1, s, ",")
aftercomma = Right(s, Len(s) - indexofthey + 1)
celld = Left(s, Len(s) - Len(aftercomma))
The code I need to somehow work this into (copied from the answer to the question I linked above) is this:
Option Explicit
Private Sub cmdCompare2to1_Click()
Dim sheet1 As Worksheet, sheet2 As Worksheet, sheet3 As Worksheet
Dim lngLastR As Long, lngCnt As Long
Dim var1 As Variant, var2 As Variant, x
Dim rng1 As Range, rng2 As Range
Set sheet1 = Worksheets(1)
Set sheet2 = Worksheets(2)
Set sheet3 = Worksheets(3) ' assumes sheet3 is a blank sheet in your workbook
Application.ScreenUpdating = False
'let's get everything all set up
'sheet3 column headers
sheet3.Range("A1:B1").Value = Array("in1Not2", "in2Not1")
'sheet1 range and fill array
With sheet1
lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng1 = .Range("A1:A" & lngLastR)
var1 = rng1
End With
'sheet2 range and fill array
With sheet2
lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng2 = .Range("A1:A" & lngLastR)
var2 = rng2
End With
'first check sheet1 against sheet2
On Error GoTo NoMatch1
For lngCnt = 1 To UBound(var1)
x = Application.WorksheetFunction.Match(var1(lngCnt, 1), rng2, False)
Next
'now check sheet2 against sheet1
On Error GoTo NoMatch2
For lngCnt = 1 To UBound(var2)
x = Application.WorksheetFunction.Match(var2(lngCnt, 1), rng1, False)
Next
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
NoMatch1:
sheet3.Range("A" & sheet3.Rows.Count).End(xlUp).Offset(1) = var1(lngCnt, 1)
Resume Next
NoMatch2:
sheet3.Range("B" & sheet3.Rows.Count).End(xlUp).Offset(1) = var2(lngCnt, 1)
Resume Next
End Sub
Assuming you do not want to change the values in your cells you will need to loop through the arrays. You can use a proc like this:
Sub RemoveUnwantedText(ByRef theArray As Variant)
Dim theValue As String
Dim i As Long
Dim indexOfComma As Integer
' array is created from single-column range of cells
' and so has 2 dimensions
For i = LBound(theArray, 1) To UBound(theArray, 1)
theValue = CStr(theArray(i, 1))
indexOfComma = InStr(1, theValue, ",")
If indexOfComma > 0 Then
theValue = Trim(Left(theValue, indexOfComma - 1))
End If
theArray(i, 1) = theValue
Next i
End Sub
Paste this into the same module as your code. In your code, before you do any comparison, add these calls:
RemoveUnwantedText var1
RemoveUnwantedText var2
I have a module in a worksheet that is supposed to pass an array to another sub in the same module. So far, I've noticed that the variable N which is being used to to pull each individual array element always says 0 in the watch window, how do I get my elements out of the array? Here is the code:
Option Explicit
Sub CreateReports()
Dim numRows As Integer
Dim numCount As Integer
Dim category As String
Dim size As Integer
Dim sizeCount As Integer
Dim departmentNums() As Integer
With Sheets("GM Alignment")
numRows = Application.WorksheetFunction.CountA(Range("A2:A1048576"))
.Range("A2").Select
Do While numCount < numRows
category = ActiveCell.Value
size = Range(ActiveCell.Offset(0, 1), ActiveCell.Offset(0, 1).End(xlToRight)).Columns.Count - 1
If size > 7 Then
size = 0
End If
ReDim departmentNums(size)
.Cells(ActiveCell.Row, 1).Select
For sizeCount = 0 To size
ActiveCell.Offset(0, 1).Select
departmentNums(sizeCount) = ActiveCell.Value
Next sizeCount
.Cells(ActiveCell.Row, 1).Select
GenerateReports Arr:=departmentNums, Sheet:=category
ActiveCell.Offset(1, 0).Select
numCount = numCount + 1
Loop
End With
End Sub
Sub GenerateReports(ByRef Arr() As Integer, Sheet As String)
Dim N As Integer
For N = LBound(Arr) To UBound(Arr)
Dim Lastrow As Long
With Sheets("DATA")
If .Range("I:I").Find(N, , xlValues, xlWhole, , , False) Is Nothing Then
MsgBox "No " + Sheet + " rows found. ", , "No Rows Copied": Exit Sub
Else
Application.ScreenUpdating = False
Lastrow = .Range("K" & Rows.Count).End(xlUp).Row
.Range("K1:K" & Lastrow).AutoFilter Field:=1, Criteria1:=N
.Range("K2:K" & Lastrow).SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sheets(Sheet).Range("A2").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
.AutoFilterMode = False
'Position on cell A3
With Application
.CutCopyMode = False
.Goto Sheets("DATA").Range("A2")
.ScreenUpdating = True
End With
MsgBox "All matching data has been copied.", , "Copy Complete"
End If
End With
Next N
End Sub
Thanks!
Not really looking too far into your code but I noticed that at no point do you read from or assign to Arr in GenerateReports. I believe you are misunderstanding how Arrays behave.
Dim index as Integer
For index = LBound(Arr) To UBound(Arr)
Debug.Print "Index: "; index; " Value: " Arr(index)
Next N
LBound(Arr) and Ubound(Arr) return the lowest and highest index of Arr not the values. In order to access the values contained in Arr use Arr(index).
If you don't care about the index you can use
Dim element as Integer
For each element in Arr
debug.Print element
Next n
It is recommended to use this method whenever possible, as it allows for other sequence's to be used such as Collection. However, it is not always possible such as when you are iterating over multiple sequences or parts of a sequence.
Here is a basic example:
Sub PrintOneToTen()
Dim xs(1 to 10) as Integer
FillArray xs
Dim x as Integer
For Each x In xs
Debug.Print x
Next x
' or just Debug.Print Join(xs, vbNewLine)
End Sub
Sub FillArray(ByRef xs() As Integer)
Dim i as Integer
For i = LBound(xs) To Ubound(xs)
xs(i) = i
Next i
End Sub
Documentation for VB.NET Arrays is listed here. Note VB.NET is not VBA, but as far as arrays are concerned 99% of the info there should be the same in VBA. I would post the VBA documentation but it's buried deep in Microsofts' database and I don't believe they care about it.