I'm new to Excel VBA, and after quite some time attempting to solve my issue, I am unable to create a working solution. The attached image is a mock up of an actual table I'm working with. I would like to:
#1 Define a date in the VBA to search for in the blue row (e.g. 05/12/2022)
#2 Once found, find all values of both 'Apple' and 'Pear' in that yellow column (Apple = 4 times, Pear = 1 time)
#3 Look at the Green column, and store the names for all matches for 'Apple' in one array (later to be used in a string), and all matches for 'Pear' in another array
#4 Input a comma delimited return of both arrays into a cell within the spreadsheet
Step #1 was completed successfully using the following code:
Public Sub MyVBA()
Dim c As Range
Dim colNum As Integer
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Set wkb = Excel.Workbooks("MyOtherWorkbook.xlsx")
Set wks = wkb.Worksheets("SheetInWorkbook")
For Each c In wks.Range("1:1")
If c.Value = "05/12/2022" Then
colNum = c.Column
End If
Next c
End Sub
Step #2 attempt:
For Each c In wks.Columns(colNum)
If c.Value = "Apple" Then
MsgBox "Apple is " & c.Address
End If
Next c
This is one of various attempts I've made at Step #2, but each time it produces errors. Advice on how to go forward with Step #2 and #3 would be appreciated.
CodePudding user response：
I've wrote something but you really need to see how its laid out on the excel file which you can find here (obviously download and run, it wont work in google sheets).
https://drive.google.com/file/d/1lSLtyYWAMVb4QM52oItbe4yK74ezquPv/view?usp=sharing
You list the data in worksheet "data", the search values (apples, pears) in worksheet "search" - then it writes them to a new worksheet called output
To run, click the big "RUN" button on the data worksheet, or run the sub.
With a little tinkering you can probably make it exactly how you want, as I didn't 100% understand your question.
Public dataWs As Worksheet
Public outputWs As Worksheet
Public searchWs As Worksheet
Function create_date(string_date)
'create a date date not a string date
Dim day, month, year As String
Dim dte As Date
day = Left(string_date, 2)
month = Mid(string_date, 4, 2)
year = Right(string_date, 2)
dte = DateSerial(Int(year), Int(month), Int(day))
create_date = dte
End Function
Function clear_outout()
'clear output worksheet
outputWs.Range("a1:z99999").Clear
End Function
Function addData(name, object)
Dim x, lr As Integer
lr = outputWs.Cells(Rows.Count, 1).End(xlUp).Row
'add columns headers if not there
If lr = 1 Then
outputWs.Cells(1, 1) = "NAME"
outputWs.Cells(1, 2) = "OBJECT"
outputWs.Cells(1, 3) = "TIMES"
End If
For x = 2 To lr 1
If x = lr 1 Then
'if not in list add name object
outputWs.Cells(x, 1) = name
outputWs.Cells(x, 2) = object
outputWs.Cells(x, 3) = 1
Exit For
ElseIf outputWs.Cells(x, 1) = name And outputWs.Cells(x, 2) = object Then
' if in list increment count
outputWs.Cells(x, 3) = outputWs.Cells(x, 3) 1
Exit For
End If
Next x
End Function
Function check_search_list(search_val)
' checks to see if input value is a match with one listed in range
Dim search_lr As Integer
'this is the search last row
search_lr = searchWs.Cells(Rows.Count, 1).End(xlUp).Row
'loop each search val
For x = 2 To search_lr
If searchWs.Cells(x, 1) = search_val Then
check_search_list = True
End If
Next x
End Function
Sub check_data()
''''
''' Run the thing
''''
'set the worksheets
Set dataWs = Worksheets("data")
Set outputWs = Worksheets("output")
Set searchWs = Worksheets("search")
Dim x, y, z, lr, lc As Integer
Dim searchDate As String
Dim found_column As Boolean
'clear output sheet
clear_outout
'this gets the pos of the last filled column to the left
lc = dataWs.Cells(1, Columns.Count).End(xlToLeft).Column
'get last row
lr = dataWs.Cells(Rows.Count, 1).End(xlUp).Row
'get the date from the user
searchDate = InputBox("Whats the date in format dd/mm/yyyy")
'create flag for date found
found_column = False
'loop columns and look for dates (as proper dates and not strings)
For y = 2 To lc
'if found then add all columns - this compares the date object, not strin g
If create_date(dataWs.Cells(1, y)) = create_date(searchDate) Then
found_column = True
'loop eaach row
For x = 2 To lr
If check_search_list(dataWs.Cells(x, y)) Then
' add the data if search value found
addData dataWs.Cells(x, 1), dataWs.Cells(x, y)
End If
Next x
'end loop as column already found
Exit For
End If
Next y
'open data if found else show message
If found_column Then
outputWs.Activate
Else
MsgBox "Date not found", vbCritical
End If
End Sub
CodePudding user response：
See the comments inside the code for the description of how this works.
There is 1 main Sub, and two helper Functions. If I were expanding this project I would also split parts of the main Sub into more Functions, to prevent this from getting too messy. For the sake of simplicity in this answer, I kept a lot in the main Sub.
Public Sub MyVBA()
Dim c As Range
Dim colNum As Long
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Set wkb = Excel.Workbooks("MyOtherWorkbook.xlsx")
Set wks = wkb.Worksheets("SheetInWorkbook")
'Get a Date as input from the user
Dim UserDate As Date: UserDate = GetUserDate()
'Exit if the user has declined to input
If UserDate = 0 Then Exit Sub
'Search for the last filled row and column
'This can be used to trim the loops so we aren't iterating through a million empty cells
Dim LastRow As Long
LastRow = wks.Columns(1).Rows(wks.Rows.Count).End(xlUp).Row
Dim LastColumn As Long
LastColumn = wks.Rows(1).Columns(wks.Columns.Count).End(xlToLeft).Column
'For each cell in Row 1
For Each c In wks.Range("1:1").Resize(, LastColumn).Cells
'if the cell contains a date & the date matches the user input
If IsDate(c.Value) Then
If CDate(c.Value) = UserDate Then
colNum = c.Column
'if the column is found, stop searching
Exit For
End If
End If
Next c
'Exit if Column not found
If colNum = 0 Then Exit Sub
'KeyRanges is a dictionary, this is an object that holds Key & Item pairs
'There is an entry in the dictionary for each keyword
'The entry's Key is the Keyword (Apple or Pear), and the item is a Collection of worksheet ranges where that keyword was found
Dim KeyRanges As Object
Set KeyRanges = CreateObject("Scripting.Dictionary")
'List of KeyWords
Dim KeyWords() As String: KeyWords = Split("Apple,Pear", ",")
'Adding an entry to the dictionary for each keyword
Dim KeyWord As Variant
For Each KeyWord In KeyWords
KeyRanges.Add KeyWord, New Collection
Next
'search the column for matches
For Each c In wks.Columns(colNum).Resize(LastRow).Cells
'compare the cell value to each keyword
For Each KeyWord In KeyWords
If c.Value = KeyWord Then
'If the cell value matches one of the keywords
'Go into the dictionary entry for that keyword
'and save the cell from this row, in column A, into the collection
KeyRanges(KeyWord).Add c.EntireRow.Cells(1)
End If
Next
Next c
'From your example for 05/12/2022
'KeyRanges now contains 2 entries
'KeyRanges("Apple") contains a Collection
'The Collection contains 4 items
'Range("A2")
'Range("A5")
'Range("A7")
'Range("A8")
'KeyRanges("Pear") contains a Collection
'The Collection contains 1 item
'Range("A4")
'Concatenate into CSV
'CSVs is an array to contain the CSV for each KeyWord
Dim CSVs() As String
ReDim CSVs(UBound(KeyWords))
'For each KeyWord
Dim i As Long
For i = 0 To UBound(KeyWords)
'Take the collection from each entry in KeyRanges
'Give it to a function which can turn collections into CSVs
CSVs(i) = JoinCollection(KeyRanges(KeyWords(i)))
Next
'Join all the CSVs into a single CSV & Output to Worksheet
Range("A1").Value = Join(CSVs, ",")
End Sub
Function GetUserDate() As Date
'Get Date From User
Dim UserInput As String
Do
UserInput = Application.InputBox(Prompt:="Date:", Default:=Date, Type:=2)
If UserInput = "" Then
'User declined to input
Exit Function
ElseIf Not IsDate(UserInput) Then
'User input not valid
UserInput = ""
MsgBox "Please enter a valid date.", vbOKOnly, "Error"
End If
Loop While UserInput = ""
GetUserDate = CDate(UserInput)
End Function
Function JoinCollection(Col As Collection, Optional Delimiter As String = ",") As String
If Col.Count = 0 Then Exit Function
Dim ReturnString As String
ReturnString = Col(1)
If Col.Count > 1 Then
Dim i As Long
For i = 2 To Col.Count
ReturnString = ReturnString & Delimiter & Col(i)
Next
End If
JoinCollection = ReturnString
End Function