I currently have the following VBA Code:
Sub SearchProjects()
Dim Ws As Worksheet
Dim NewSheet As Worksheet
Set NewSheet = Worksheets("Sheet1")
Dim Rng As Range, rng2 As Range
Dim myCell As Object
Dim cell2 As Object
Dim proj As String, d As Date
Dim m As Variant
Set Ws = Worksheets("Project tasks")
Ws.Activate
Set Rng = Ws.Range("D:D")
Set rng2 = Range("DatesByWeek").EntireRow 'row 4 of my "Sheet1"
searchString = "Lisa"
For Each Cell In Rng
If InStr(Cell, searchString) > 0 Then
proj = Cells(Cell.Row, Range("ProjectName").Column)
'so here d is a date found that corresponds to Lisa's project name, e.g. d = "25/07/2022"
d = Format(Cells(Cell.Row, Range("StartDate").Column), "dd/mm/yyyy")
m = WorksheetFunction.Match(d, rng2, 1) 'Searches Row 4 for any matches to the date d
msgbox(m)
End If
Next Cell
End Sub
When I do in normal excel function =MATCH("25/07/2022", 4:4, 1) it does return the correct column number, however the vba code continues to get the error:
Unable to get the match property of the WorksheetFunction class.
I'm not sure why it is an error in VBA?
Any help appreciated
Maybe you could try: (Just from the top of my head, have not been able to replicate the error)
Dim res As Variant
res = WorksheetFunction.Match(d, rng2, 1)
If Not IsError(res) Then
Msgbox res
End If
Related
I'm trying to return the partial match string on a column right beside the column with the text I'm trying to search within. This is the code I tried to write. What would be a better way to do this?
Essentially I have a column with:
Column 1
aaaaa1111
...
zzzzz9999
Column 2
aaa
bbb
..
zzz
I want to return column 2 values to the column adjacent to column 1 where the column 2's string can be found within column 1.
Sub match()
Dim ws As Worksheet
Dim vendors As Range
Dim description As Range
Dim match As Range
Dim cell As Range
Dim j As Integer
Dim i As Integer
Set vendors = ws.Range("ae2:ae1007").Text
Set description = ws.Range("o2:o32609")
Set match = ws.Range("p2:p32609")
For i = 2 To 32609
For j = 2 To 1007
If InStr(description.Cells(i, "O"), vendors.Range(j, "AE")) > 0 Then
match.Cells(i, "P") = vendors.Range(j, "AE").Text
Else: match.Cells(i, "P") = "#N/A"
End If
Next j
Next i
End Sub
Update: (I get run-time error '91' on line 9)
Sub match()
Dim ws As Worksheet
Dim cell As Range
Dim j As Integer
Dim i As Integer
For i = 2 To 32609
For j = 2 To 1007
If InStr(ws.Cells(i, "O"), ws.Cells(j, "AE")) > 0 Then
ws.Cells(i, "P") = ws.Cells(j, "AE").Text
Else: ws.Cells(i, "P") = "#N/A"
End If
Next j
Next i
End Sub
You are getting error 91 because you declared ws but did not set ws to any worksheet.
The code below should run pretty fast since it process the data in an array (read/write from cells is a very slow process).
Option Explicit
Sub FindMatch()
Const vendorCol As String = "AE"
Const descCol As String = "O"
Const matchCol As String = "P"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Change name accordingly
'==== Get a list of unique vendor names
Dim vendorDict As Object
Set vendorDict = CreateObject("Scripting.Dictionary")
vendorDict.CompareMode = vbTextCompare
Dim vendorLastRow As Long
Dim vendorInput As Variant
'Assign the values of the vendor names to array
vendorLastRow = ws.Cells(ws.Rows.Count, vendorCol).End(xlUp).Row
vendorInput = ws.Range(ws.Cells(2, vendorCol), ws.Cells(vendorLastRow, vendorCol)).Value
'Loop through the array and add to dictionary if it's not already in it
Dim n As Long
For n = 1 To UBound(vendorInput, 1)
If Not vendorDict.Exists(vendorInput(n, 1)) Then vendorDict.Add vendorInput(n, 1), 1
Next n
Dim vendorArr As Variant
vendorArr = vendorDict.keys
Set vendorDict = Nothing
Erase vendorInput
'====
'Assign the values of description to array
Dim descLastRow As Long
Dim descArr As Variant
descLastRow = ws.Cells(ws.Rows.Count, descCol).End(xlUp).Row
descArr = ws.Range(ws.Cells(2, descCol), ws.Cells(descLastRow, descCol)).Value
'Create an array of the same size as the description for match result, will be used to write in to the worksheet once at the end
Dim matchArr() As Variant
ReDim matchArr(1 To UBound(descArr, 1), 1 To 1) As Variant
'Loop through the description array and within the loop, check if there's a match in the vendor array
Dim i As Long
For i = 1 To UBound(descArr, 1)
For n = 0 To UBound(vendorArr)
If InStr(1, descArr(i, 1), vendorArr(n), vbTextCompare) <> 0 Then
'If match found, assign the vendor name to the match array
matchArr(i, 1) = vendorArr(n)
Exit For
End If
Next n
'If no match, return NA error
If matchArr(i, 1) = vbNullString Then matchArr(i, 1) = CVErr(xlErrNA)
Next i
ws.Cells(2, matchCol).Resize(UBound(matchArr, 1)).Value = matchArr
Erase descArr
Erase matchArr
End Sub
Compare Two Columns
This is a basic example that loops through column O and compares each value against each value in column AE. Match is no good because the values in AE need to be contained in O. You can always improve efficiency by using arrays as illustrated in Raymond Wu's answer.
On the other hand, you could loop through column AE and use the Find and FindNext methods to find all matches in column O which might also be more efficient.
Option Explicit
Sub MatchVendors()
' s - Source (read from ('vendors'))
' d - Destination (read from ('description') and written to ('match'))
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1") ' adjust, often...
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1") ' ... different
Dim slRow As Long: slRow = sws.Range("AE" & sws.Rows.Count).End(xlUp).Row
If slRow < 2 Then Exit Sub ' no data in source
Dim srg As Range: Set srg = sws.Range("AE2:AE" & slRow)
Dim dlRow As Long: dlRow = dws.Range("O" & dws.Rows.Count).End(xlUp).Row
If dlRow < 2 Then Exit Sub ' no data in destination
Dim drg As Range: Set drg = dws.Range("O2:O" & dlRow)
Application.ScreenUpdating = False
Dim sCell As Range
Dim dCell As Range
Dim IsMatch As Boolean
For Each dCell In drg.Cells
' Read (Search)
For Each sCell In srg.Cells
' Either 'contains'...
If InStr(1, dCell.Value, sCell.Value, vbTextCompare) > 0 Then
' ... or 'begins with':
'If InStr(1, dCell.Value, sCell.Value, vbTextCompare) = 1 Then
IsMatch = True
Exit For
End If
Next sCell
' Write
If IsMatch Then
dCell.EntireRow.Columns("P").Value = sCell.Value
IsMatch = False
Else
dCell.EntireRow.Columns("P").Value = "#N/A"
End If
Next dCell
Application.ScreenUpdating = True
MsgBox "Vendors matched to Descriptions.", vbInformation
End Sub
I have two sheets sheet1 "kintai_demo" [having 3 columns 'employeid' 'date' 'attendence' ) and sheet2 "kintai_test"(having 1st column 'employeid'[F8:F26] and dates[H6:AL6(2020/dec/21-2021/jan/20)].
I transfer data from kintai_demo to kintai_test by matching employeid and dates so their attendence shows in the sheet2 employid on the left dates on top left to right like [P, A, off, HD, etc.].
Doing it with lookat works till dec 31 and stops at 1st jan and gives error 91.
Private Sub CommandButton1_Click()
'????
Dim myRange As Range
Dim myRange_day As Range
Dim myObj As Range
Dim myObj_day As Range
Dim myObj_emply As Range
Dim keyWord As String
Dim keyWord_day As String
Dim date_range As Range
Dim emplyObj As Range
Dim keyWord_emply As String
Set myRange = Sheets("kintai_test").Range("F8:F26")
Set myRange_day = Sheets("kintai_test").Range("H6:AL6")
Set myObj_emply = Sheets("kintai_test").Range("F8:F26")
'For loop variable
Dim i As Integer
Dim a As Integer
Dim j As Integer
For i = 2 To 14
'??????
'Set myObj = myRange.Find(keyWord, LookAt:=xlWhole)
For a = 8 To 36
For j = 8 To 15
keyWord = Sheets("kintai_demo").Cells(i, 1).Value
keyWord_day = Sheets("kintai_demo").Cells(i, 2).Value
keyWord_emply = Sheets("kintai_demo").Cells(i, 1).Value
'(????)date search
Set myObj_day = myRange_day.Find(What:=keyWord_day, LookIn:=xlFormulas, LookAt:=xlWhole)
'(????)employe id search
Set myObj_emply = myObj_emply.Find(What:=keyWord_emply, LookIn:=xlFormulas, LookAt:=xlWhole)
'this line shows error 91
Sheets("kintai_test").Cells(myObj_emply.Row, myObj_day.Column).Value = Sheets("kintai_demo").Cells(i, 3).Value
i = i + 1
Next j
Next a
Next i
End Sub
I add conditions after each rng.find method. If range not found msgbox will be shown
Private Sub CommandButton1_Click()
'????
Dim myRange As Range
Dim myRange_day As Range
Dim myObj As Range
Dim myObj_day As Range
Dim myObj_emply As Range
Dim myObj_emply_found As Range
Dim keyWord As String
Dim keyWord_day As String
Dim date_range As Range
Dim emplyObj As Range
Dim keyWord_emply As String
Set myRange = Sheets("kintai_test").Range("F8:F26")
Set myRange_day = Sheets("kintai_test").Range("H6:AL6")
Set myObj_emply = Sheets("kintai_test").Range("F8:F26")
'For loop variable
Dim i As Integer
Dim a As Integer
Dim j As Integer
For i = 2 To 14
'??????
'Set myObj = myRange.Find(keyWord, LookAt:=xlWhole)
For a = 8 To 36
For j = 8 To 15
keyWord = Sheets("kintai_demo").Cells(i, 1).Value
keyWord_day = Sheets("kintai_demo").Cells(i, 2).Value
keyWord_emply = Sheets("kintai_demo").Cells(i, 1).Value
'(????)date search
Set myObj_day = myRange_day.Find(What:=keyWord_day, LookIn:=xlFormulas, LookAt:=xlWhole)
If myObj_day Is Nothing Then MsgBox "not found myObj_day ", vbCritical, ""
'(????)employe id search
' you cant use same variable to set range where you lookup and assign to him range found
' i add new variable myObj_emply_found
Set myObj_emply_found = myObj_emply.Find(What:=keyWord_emply, LookIn:=xlFormulas, LookAt:=xlWhole)
If myObj_emply_found Is Nothing Then MsgBox "not found myObj_emply_found ", vbCritical, ""
'this line shows error 91
'AND CONDITION TO DO IF BOTH FOUND
If Not myObj_day Is Nothing And Not myObj_emply_found Is Nothing Then
Sheets("kintai_test").Cells(myObj_emply_found .Row, myObj_day.Column).Value = Sheets("kintai_demo").Cells(i, 3).Value
End If
i = i + 1
Next j
Next a
Next i
End Sub
I am trying to add data to a Listbox on a Userform, based on the value of the the Cell in column C of the range that is searched. If the cell in column C contains a certain string I would like it to be added to the Listbox.
The below code is as far as I have got but it is returning an empty Listbox with no error.
Private Sub OptionButton12_Click()
Dim I As Integer
Dim lastRow As Integer
Dim searchString As String
searchString = "LISTBOXENTRY"
With ThisWorkbook.Sheets("Sheet1")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Plybooks.ListBox1.Clear
For I = 1 To lastRow
If Cells(I, 3).Value = searchString Then
Plybooks.ListBox1.AddItem Range("A" & I)
End If
Next I
End Sub
Try using the script below and please let me know if it works!
based on your script above, I assumed some of the dataframe dimensions. please let me know if it is not correct so I can tweak it.
I assumed you are working on first sheet (sheets(1)), and col C is the column you are using for the value check against the "searchString" variable. (if true, append the value in listbox1)
Thanks
Private Sub OptionButton12_Click()
Dim lastRow As Integer
Dim searchString As String
Dim wb As Workbook
Dim sRng As Range
Dim cel As Range
'assign current wb into wb workbook object
Set wb = ThisWorkbook
'assign str you want to search into variable
searchString = "LISTBOXENTRY"
'find last row number in colC (3) using crow function. (assuming you want to do a check on every cell listed in column C)
lastRow = crow(1, 3)
plybooks.listbox1.Clear
'assign range object using dataframe dimensions based on row 1 col C (lbound), to lastrow col3 (ubound)
With wb.Sheets(1)
Set sRng = .Range(.Cells(1, 3), .Cells(trow, 3))
End With
'loops through each cel
For Each cel In sRng
If cel.Value = searchString Then
'adds item into listbox1 if conditional statement is True
plybooks.listbox1.AddItem Item:=cel.Value
Else
End If
Next cel
End Sub
Private Function crow(s As Variant, c As Integer)
crow = Sheets(s).Cells(Rows.Count, c).End(xlUp).Row
End Function
Added cell values in ranges over multiple sheets if cell contains certain value, using the following:
Public Sub PlybookListbox()
'Clear fields before start
Plybooks.ListBox1.MultiSelect = 0
Plybooks.ListBox1.Clear
Plybooks.ListBox1.Value = ""
Plybooks.ListBox1.MultiSelect = 2
Dim AllAreas(2) As Range, Idx As Integer, MyCell As Range, TargetRange As Range
Dim lastrowFrontWing As Long
Dim lastrowNose As Long
Dim lastrowBargeboard As Long
lastrowFrontWing = Worksheets("Front Wing").Cells(Rows.Count, 2).End(xlUp).Row
lastrowNose = Worksheets("Nose").Cells(Rows.Count, 2).End(xlUp).Row
lastrowBargeboard = Worksheets("Bargeboard & SPV").Cells(Rows.Count, 2).End(xlUp).Row
Set AllAreas(0) = Worksheets("Front Wing").Range("c6:c" & lastrowFrontWing)
Set AllAreas(1) = Worksheets("Nose").Range("c6:c" & lastrowNose)
Set AllAreas(2) = Worksheets("Bargeboard & SPV").Range("c6:c" & lastrowBargeboard)
Plybooks.ListBox1.Clear
For Idx = 0 To 2
For Each MyCell In AllAreas(Idx).Cells
If InStr(1, MyCell.Value, "(FS)") > 0 Then
Plybooks.ListBox1.AddItem MyCell.Value
End If
Next MyCell
Next Idx
End Sub
In VBA, I wish to find the row count of a filtered column, so I wrote VBA code as
FilteredRowCount = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible).Rows.Count
But FilteredRowCount always return value of 1, what would cause this?
Do like this
Sub test()
Dim Ws As Worksheet
Dim rngDB As Range
Dim r As Integer
Dim rng As Range
Set Ws = ActiveSheet
Set rngDB = Ws.UsedRange.SpecialCells(xlCellTypeVisible)
For Each rng In rngDB.Areas
r = r + rng.Rows.Count
Next rng
MsgBox r
End Sub
I'm trying to compare two columns in two different WB let's say A and B which have only column each.
I'd like to msgbox a text whenever the value of cell in the column of A is also in the column of B.
I managed to put values in a variant variable and like now to compare them. I still get a 424 error at the final if statement that checks the correspondance.
Here is the code :
Option Explicit
Sub uniformisation()
Dim range1 As Variant
Dim range2 As Variant
Dim Tab1 As Variant, tab2 As Variant
Dim fichierM As Workbook
Dim fichierF As Workbook
Set fichierF = Workbooks.Open("thepath")
Set fichierMission = Workbooks.Open("thepath")
fichierF.Activate
fichierM.Activate
Dim wsF As Worksheet
Dim wsM As Worksheet
Set wsF = fichierF.Worksheets("test")
Set wsM = fichierM.Worksheets("A")
Dim C As range
Dim D As range
Set C = wsFlex.Columns(1)
Set D = wsMiss.Columns(1)
Dim TotalRows1 As Long
Dim TotalRows2 As Long
With wsF
TotalRows1 = C.Rows(Rows.Count).End(xlUp).Row
Tab1 = range(Cells(2, 1), Cells(TotalRows1, 1)).Value
MsgBox UBound(Tab1)
End With
With wsM
TotalRows2 = Rows(D.Rows.Count).End(xlUp).Row
tab2 = range(Cells(2, 2=1), Cells(TotalRows2, 1))
MsgBox UBound(tab2)
End With
For Each range1 In Tab1
For Each range2 In tab2
If range1.Value = range2.Value Then
MsgBox range1
End If
Next range2
Next range1
fichierM.Close
fichierF.Close
End Sub
Any help would be really apreciated, thanks !
you definitions are all over the place and the code is too long for what it is supposed to do. Also, you have chosen variant which is not really needed for what you want to do. Here is a shorter version that can get you started:
Sub CompareTwoColumns()
Dim rng1 As Range
Dim rng2 As Range
Dim WB1 As Workbook
Dim WB2 As Workbook
'make sure both workbooks are open
Set WB1 = Workbooks.Open("thepath1")
Set WB2 = Workbooks.Open("thepath2")
'loop through both columns and compare
For Each rng1 In WB1.Worksheets("Sheet1").UsedRange.Columns(1).Cells
For Each rng2 In WB2.Worksheets("Sheet1").UsedRange.Columns(1).Cells
If rng1.Value = rng2.Value Then
MsgBox rng1.Value
End If
Next rng2
Next rng1
End Sub