I am trying to add a wildcard character to the search box, but the execution continues even without anything in the search box, how should i stop the search if the box is empty?
Thank you
For Each Cognome In intervallo
If Cognome Like Sheets(1).Ricerca = "" Then
Exit For
ElseIf Cognome Like Sheets(1).Ricerca & "*" Then
Sheets(4).Range(Cognome, Cognome.Offset(0, 8)).Copy
Sheets(1).Range("A" & (Rows.Count)).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Check for a search term before entering the loop
Sub MyMacro()
Dim s As String, r As Long
Dim Cognome As Range, intervallo As Range
Set intervallo = Sheets(4).Range("A1:A100")
r = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
s = Trim(Sheets(1).Ricerca)
If Len(s) = 0 Then
MsgBox "Search box empty", vbExclamation
Else
For Each Cognome In intervallo
If Cognome.Value2 Like s & "*" Then
r = r + 1
Cognome.Resize(1, 8).Copy
Sheets(1).Range("A" & r).PasteSpecial xlPasteValues
End If
Next
End If
End Sub
Related
I am a beginner on vba, sarching and reading different things about vba I have created a piece of code but doesn't work how I want to. If I search for a specific value the code find it and show on specific textboxes a specific value, but if there are more than one same values (in searching column) I want to make the code go to next one until find every same value, what my actual code doesn't do. Any help on improving this code or any other code that does it I appreciate.
Here is my code,
Private Sub Search_Click()
Dim a As String
Dim b As Double
Dim k As Range
On Error GoTo dontexist:
If Me.TextBox20.Value = "" Or Me.TextBox20.Value = "Number of invoice" Then
Me.Label29.Caption = "Number of invoice"
b = Me.TextBox24.Value
Set k = Sheets("Sheet2").Range("E:E")
r = Application.WorksheetFunction.Match(b, k, 0)
Me.TextBox21.Value = Sheets("Sheet2").Cells(r, 2).Value
Me.TextBox22.Value = Sheets("Sheet2").Cells(r, 8).Value
Me.TextBox23.Value = Sheets("Sheet2").Cells(r, 4).Value
Exit Sub
Else
Me.Label29.Caption = "Sum of invoice"
a = Me.TextBox20.Value
Set k = Sheets("Sheet2").Range("H:H")
r = Application.WorksheetFunction.Match(a, k, 0)
Me.TextBox21.Value = Sheets("Sheet2").Cells(r, 2).Value
Me.TextBox22.Value = Sheets("Sheet2").Cells(r, 5).Value
Me.TextBox23.Value = Sheets("Sheet2").Cells(r, 4).Value
Exit Sub
End If
dontexist:
MsgBox "This record dosn't exist!", vbInformation, "Info!"
End Sub
Add a label to your form to hold the last found row and start the search from there. I have used label30.
Option Explicit
Private Sub Search_Click()
Dim rngSearch As Range, rngFound As Range, sColumn As String
Dim sValue As String, iCount As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet2")
' label to hold row to start search at
If Label30 = "" Then Label30 = "1"
If Len(TextBox24) > 0 Then
' search on number
sValue = TextBox24
sColumn = "E"
Label29 = "Number of invoice"
ElseIf Len(TextBox20) > 0 Then
' search on total
sValue = TextBox20
sColumn = "H"
Label29 = "Sum of invoice"
Else
MsgBox "No search values entered", vbExclamation
Exit Sub
End If
' count number of matches
Set rngSearch = ws.Cells(1, sColumn).EntireColumn
iCount = Application.WorksheetFunction.CountIf(rngSearch, sValue)
If iCount > 0 Then
' continue search from last position
Set rngFound = rngSearch.Find(sValue, _
After:= ws.Range(sColumn & Label30), _
LookIn:=xlValues, _
LookAt:=xlWhole)
If rngFound Is Nothing Then
' not found
Label30 = ""
MsgBox "No more records found"
Else
' is row new
If rngFound.Row > Label30 Then
'MsgBox rngFound.Row
' copy into text boxes
With rngFound.EntireRow
If sColumn = "E" Then
TextBox21 = .Cells(1, 2)
TextBox22 = .Cells(1, 8)
TextBox23 = .Cells(1, 4)
Else
TextBox21 = .Cells(1, 2)
TextBox22 = .Cells(1, 5)
TextBox23 = .Cells(1, 4)
End If
End With
Label30 = rngFound.Row
Else
MsgBox "No more records found", vbExclamation
Label30 = ""
Exit Sub
End If
End If
Else
MsgBox "No records found", vbExclamation
Label30 = ""
End If
End Sub
Get the row # of cell that matches with search "string" in particular column without loop - Column has multiple matches"
I want to get the row # of matched string in particular column without looping because i have more than 50000 records and I don't want to loop each row to find out
Sub Mismatch()
Dim sht As Worksheet
Set Sht5 = ThisWorkbook.Worksheets("Result")
Dim FindString As String
FindString = "FAIL"
Sht5.Activate
Columncount = Sht5.Range(Cells(1, 1), Cells(1, 1000)).Cells.SpecialCells(xlCellTypeConstants).Count 'CODE NEED TO BE UPDATED WITH COLUMN LENGTH
'To find the column count
lastReportRow = Sht5.Range("B" & Rows.Count).End(xlUp).row
'to find the last used row
For i = 2 To Columncount + 1
Set Valuefound = Sht5.Range(Cells(2, i), Cells(lastReportRow, i)).Find(FindString, After:=Range("B2"), LookIn:=xlValues)
If Valuefound Is Nothing Then
MsgBox "Value not found"
Else
For r = 2 To lastReportRow
ActualString = Sht5.Cells(r, i).Value
If FindString = ActualString Then
MsgBox r
Else
End If
'For x = 2 To lastReportRow
Next
End If
Next
End Sub
You can use Match:
'...
lastReportRow = Sht5.Range("B" & Rows.Count).End(xlUp).row
For i = 2 To Columncount + 1
Set rng = Sht5.Range(Sht5.Cells(2, i), Sht5.Cells(lastReportRow, i))
Do
m = Application.Match(FindString, rng, 0)
If IsError(m) Then Exit Do '<< not found: exit search for this column
Debug.Print "Found '" & FindString & "' at " & rng.Cells(m).Address
'reset search range
Set rng = Sht5.Range(rng.Cells(m+1), Sht5.Cells(lastReportRow, i))
Loop
Next i
End Sub
See in your code you can replace:
This:
For i = 2 To Columncount + 1
Set Valuefound = Sht5.Range(Cells(2, i), Cells(lastReportRow,
i)).Find(FindString, After:=Range("B2"), LookIn:=xlValues)
If Valuefound Is Nothing Then
MsgBox "Value not found"
Else
For r = 2 To lastReportRow
ActualString = Sht5.Cells(r, i).Value
If FindString = ActualString Then
MsgBox r
Else
End If
'For x = 2 To lastReportRow
Next
End If
Next
With This:
Set Valuefound = sht5.UsedRange.Find(FindString, After:=Range("B2"), LookIn:=xlValues, lookat:=xlWhole)
If Valuefound Is Nothing Then
MsgBox "Value not found"
Else
MsgBox Valuefound.Row
End If
Valuefound.row will give you the exact row. Also you can add Valuefound.column to get the column number of the Valuefound
Also, you can add Range.FindNext as per this link to access the values that occur more than once in the data.
I have a Userform with a listbox for which I am using conditional logic to determine output values to the sheet of selected or non-selected items in the listbox. The issue is that when the Textbox (Tbl_AliasName) is blank, the code executes this:
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
But if Tbl_AliasName is not blank then the code does nothing, but it is supposed to do this:
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
I have used several variations of If statements, and non of which have worked.
Below is My Code:
Option Explicit
Public Tbl_AliasName As String
Tbl_AliasName = Trim(UserForm_Finder.txtConcat.Value)
Private Sub BtnConcat_Click()
Dim k As Long, lstbxRow As Long, LR As Long
lstbxRow = 1
'****************
'This if statement works perfectly
If (Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) _
And Tbl_AliasName = vbNullString Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf (UserForm_Finder.ListBx_TblsCols.ListCount = 0 And Tbl_AliasName <> vbNullString) Then
MsgBox "You must Search for a Table or Column first.", _
vbExclamation, "Error Encountered"
'(Cells(2, 1).Value2 = vbNullString Or Cells(2, 2).Value2 = vbNullString) And _
Exit Sub
End If
With UserForm_Finder.ListBx_TblsCols
For k = 0 To .ListCount - 1
'****************
This is where the problems begin
If .Selected(k) = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
ElseIf .Selected(k) = True And Tbl_AliasName <> vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Tbl_AliasName & "." & .Column(1, k)
ElseIf .Selected(k) = True And Tbl_AliasName = vbNullString Then
lstbxRow = lstbxRow + 1
Worksheets("New TRAX").Cells(lstbxRow, 3) = Trim(Cells(2, 1).Value2) & "." & .Column(1, k)
End If
Next k
End With
End Sub
My goal is to do the following:
If a Textbox (Tbl_AliasName) is not blank and the user has selected one or more items in the listbox (ListBx_TbleCols) then concatenate the Tbl_AliasName to the selected items in the listbox
If Tbl_AliasName is blank, then use the value in Cells(2,1) to concatenate to the selected Items in the list box.
I have tried the following additions:
Dim LstBxItemSelected As Boolean
'This was placed in the for loop
LstBxItemSelected = True
'this was placed outside the for loop
If LstBxItemSelected = False Then
MsgBox "You must Select 1 or more items from the list box.", _
vbExclamation, "Error Encountered"
Exit Sub
End If
Is there a better way to tell if items are selected, because I feel that the way I have it structured in my loop, the code will throw the error if everything isn't selected? Thank you in advance for any ideas, answers, or suggestions!
Note: The Listbox is populated by the click of another button on the userform which calls the following sub:
Sub FillLstBxCols()
Dim ListBx_Target As MSForms.ListBox
Dim rngSource As Range
Dim LR As Long
If Cells(2, 1).Value2 <> vbNullString Then
LR = Worksheets("New TRAX").Cells(Rows.Count, 2).End(xlUp).Row
'Set reference to the range of data to be filled
Set rngSource = Worksheets("New Trax").Range("A" & 2 & ":" & "B" & LR)
'Fill the listbox
Set ListBx_Target = UserForm_Finder.ListBx_TblsCols
With ListBx_Target
.RowSource = rngSource.Address
End With
End If
End Sub
Hard to say without sample data and expected results, but I think this is what you're looking for:
Private Sub btnConcat_Click()
Dim ws As Worksheet
Dim bSelected As Boolean
Dim sConcat As String
Dim i As Long, lRowIndex As Long
Set ws = ActiveWorkbook.Sheets("New TRAX")
lRowIndex = 1
bSelected = False
sConcat = Trim(Me.txtConcat.Text)
If Len(sConcat) = 0 Then sConcat = Trim(ws.Cells(2, "A").Value)
If Len(sConcat) = 0 Then
MsgBox "You must Search for a Table or Column first.", vbExclamation, "Error Encountered"
Exit Sub
End If
For i = 0 To Me.ListBx_TblsCols.ListCount - 1
If Me.ListBx_TblsCols.Selected(i) Then
If bSelected = False Then
bSelected = True
ws.Range("C2", ws.Cells(ws.Rows.Count, "C")).Clear 'clear previous concat results (delete this line if not needed)
End If
lRowIndex = lRowIndex + 1
ws.Cells(lRowIndex, "C").Value = sConcat & "." & Me.ListBx_TblsCols.List(i)
End If
Next i
If bSelected = False Then MsgBox "Must select at least one item from the list"
End Sub
I am trying to put the value of the cell that is after the one with the string "Senast", into cell Q2. The code below does not work. Any ideas why?
Sub Find_Data()
Dim item_in_review As Variant
Dim row_number As Long
For row_number = 1 To 1000 Step 1
item_in_review = Sheets("Investor_Importerad data").Range("A" & row_number)
If InStr(item_in_review, "Senast") Then
row_number = row_number + 1
Worksheets("Översikt innehavCells").Cells(2, "Q").Value = Worksheets("Investor_Importerad data").Cells(row_number, "A").Value
Exit For
End If
If item_in_review = 300 Then
MsgBox "300"
Exit For
End If
Next row_number
End Sub
It seems that you are looking to either a wildcard match to Senast or the number 300 as a true number. Whichever comes first, you exit your For ... Next loop.
The following is filled with numerous error trapping and criteria conditions that should isolate your problem.
Sub Find_Data()
Dim rSenast As Variant, r300 As Variant, wsn As String
wsn = "Översikt innehavCells"
Dim row_number As Long
With Worksheets("Investor_Importerad data")
rSenast = Application.Match("*senast*", .Range("a:a"), 0)
r300 = Application.Match(300, .Range("a:a"), 0)
If IsError(r300) Then _
r300 = Application.Match(Format(300, "0"), .Range("a:a"), 0)
Select Case True
Case CBool(IsNumeric(rSenast) And IsNumeric(r300))
If r300 < rSenast Then
If MsgBox("300 found before 'senast" & vbLf & "Continue with value transfer?", vbYesNo, "Continue?") <> vbYes Then _
Exit Sub
End If
Case CBool(IsError(rSenast) And IsError(r300))
MsgBox "Neither 'senast' nor 300 can be found"
Exit Sub
Case CBool(IsError(rSenast) And IsNumeric(r300))
MsgBox "300 can be found at row " & r300
Exit Sub
End Select
On Error GoTo No_Such_Worksheet
If .Cells(rSenast + 1, "A").Value <> vbNullString Then
Worksheets(wsn).Cells(2, "Q") = .Cells(rSenast + 1, "A").Value
Else
MsgBox .Cells(rSenast + 1, "A").Address(0, 0) & " appears to be empty"
End If
On Error GoTo 0
End With
Exit Sub
No_Such_Worksheet:
With Worksheets.Add(after:=Worksheets("Investor_Importerad data"))
.Name = wsn
End With
Resume
End Sub
First off thank you very much. Over the last few months (i believe) my coding has progressed drastically. Any and all criticize is always welcome (rip me apart).
Recently I started to try to use different Subs (I dont quite understand when to use functions etc, but i figure it is good structure practice for when i figure it out.
I am hitting a Run-time 424 Error with the following bit of code in Sub ownerCHECK
Sub OccupationNORMALIZATION()
Dim infoBX As String
' initialize variables
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
Do While infoBX = ""
infoBX = InputBox("Enter Occupation Column", "Occupation Column")
Loop
restaurCHECK (infoBX)
Application.ScreenUpdating = True
Application.StatusBar = ""
End Sub
-
Sub restaurCHECK(infoBX As String)
Dim RestaurantS(), RestaurantDQs() As Variant
Dim i, LRow, LCol, STATUScounter As Long
Dim rRng As Range
LRow = ActiveSheet.UsedRange.Rows.Count
LCol = ActiveSheet.UsedRange.Columns.Count
STATUScounter = LRow
RestaurantS = Array("estaur", "food", "cafe", "beverage", "waiter", "waitr", _
"waitstaff", "wait staff", "grill") 'array list of target occupations
RestaurantDQs = Array("fast", "pub", "import", "packing", "processing", "packag", _
"retired", "anufact", "distrib") ' disqualifying words for Restaurante category
Set rRng = Range(infoBX & "2:" & infoBX & LRow)
Application.ScreenUpdating = False
For Each cell In rRng
ownerCHECK (cell)
For i = LBound(RestaurantS) To UBound(RestaurantS)
If InStrRev(cell.Value, UCase(RestaurantS(i))) > 0 Then
cell.Offset(, 1) = "Restaurants"
cell.Interior.Color = 52479
End If
Debug.Print cell.Value
Next
For i = LBound(RestaurantDQs) To UBound(RestaurantDQs)
If InStrRev(cell.Value, UCase(RestaurantDQs(i))) And cell.Interior.Color = 52479 Then
cell.Interior.Color = 255
cell.Offset(, 1) = ""
End If
Next
STATUScounter = STATUScounter - 1
Application.StatusBar = "REMAINING ROWS " & STATUScounter & " tristram "
Next cell
End Sub
-
Sub ownerCHECK(str_owner As Range)
Dim owner() As Variant
owner() = Array("owner", "shareholder", "owns ")
For i = LBound(owner) To UBound(owner)
If InStrRev(str_owner, UCase(owner(i))) > 0 Then
cell.Offset(, 2) = "Owner"
End If
Next
End Sub
I can see a couple of issues in ownerCHECK():
"cell" is not defined (unless it's global)
you shouldn't use "cell" as a variable name (internal VBA property)
check validity of incoming range
.
Option Explicit
Sub ownerCHECK(ByRef rngOwner As Range)
If Not rngOwner Is Nothing Then
Dim owner() As Variant
owner() = Array("OWNER", "SHAREHOLDER", "OWNS ")
For i = LBound(owner) To UBound(owner)
If InStrRev(UCase(rngOwner), owner(i)) > 0 Then
rngOwner.Offset(, 2) = "Owner"
End If
Next
End If
End Sub