This is a shortened version, but the intent is it looks if the value of txtcustomer does exists in the customerref list, if not then it matches only txtmodel and txtbounce to their respective cells. If the value does exist on the list then it matches txtmodel, txtbounce and txtcustomer to their respective cells.
It mostly works but the "if value exists" part is putting all values in the list together rather keeping those values segregated to their own ranges. It doesn't seem to be matching all three criteria though that section does work correctly if that is the only bit of code.
Private Sub cmdAdd_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Output")
Dim nextBlankCell As Range
Dim customerRef As Range
Set customerRef = ThisWorkbook.Worksheets("Ref").Range("K2:K12")
If Not customerRef.Find(TravelerForm.txtCustomer.Value) Is Nothing Then
If ws.Cells(12, 1) = "" Or (ws.Cells(12, 1) = TravelerForm.txtModel.Value And ws.Cells(10, 3) = TravelerForm.txtBounce.Value) Then
Set nextBlankCell = ws.Range("A13:A54").Find("", LookIn:=xlValues)
If Not nextBlankCell Is Nothing Then
nextBlankCell.Value = TravelerForm.txtSerial.Value
nextBlankCell.Select
Else
MsgBox "No blank cells found in range A13:A54"
End If
ElseIf ws.Cells(12, 7) = "" Or (ws.Cells(12, 7) = TravelerForm.txtModel.Value And ws.Cells(10, 9) = TravelerForm.txtBounce.Value) Then
Set nextBlankCell = ws.Range("G13:G54").Find("", LookIn:=xlValues)
If Not nextBlankCell Is Nothing Then
nextBlankCell.Value = TravelerForm.txtSerial.Value
nextBlankCell.Select
Else
MsgBox "No blank cells found in range G13:G54"
End If
End If
Else
If ws.Cells(12, 1) = "" Or (ws.Cells(12, 1) = TravelerForm.txtModel.Value And ws.Cells(10, 3) = TravelerForm.txtBounce.Value And ws.Cells(12, 4) = TravelerForm.txtCustomer.Value) Then
Set nextBlankCell = ws.Range("A13:A54").Find("", LookIn:=xlValues)
If Not nextBlankCell Is Nothing Then
nextBlankCell.Value = TravelerForm.txtSerial.Value
nextBlankCell.Select
Else
MsgBox "No blank cells found in range A13:A54"
End If
ElseIf ws.Cells(12, 7) = "" Or (ws.Cells(12, 7) = TravelerForm.txtModel.Value And ws.Cells(10, 9) = TravelerForm.txtBounce.Value And ws.Cells(12, 10) = TravelerForm.txtCustomer.Value) Then
Set nextBlankCell = ws.Range("G13:G54").Find("", LookIn:=xlValues)
If Not nextBlankCell Is Nothing Then
nextBlankCell.Value = TravelerForm.txtSerial.Value
nextBlankCell.Select
Else
MsgBox "No blank cells found in range G13:G54"
End If
End If
Related
I am desperate now. :(
I have a list of activities in a column in a sheet. In another sheet I have another list of activities, some of which match entries in the list in the first sheet. The code goes through the first list and finds a match in the second list. Then it checks how many outputs this match has, and if there are more than one outputs, it adds another row in the first list of data, right below the last checked cell of that list. On that new row an entry based on the second output should get written. If there is a further output, another new row gets added etc. until there are no more outputs of the same activity. Then it shall continue with the next activity from the first list. That next activity cell shall be therefore moved with the number of rows added additionally during the check.
The problem is, sometimes that moving with the number of additional rows seems to not be enough, so it happens that the next cell is actually a previous one from the list, i.e. an already checked one, and not a new one. And thus an indefinite cycle occurs. To bypass this, I even try to save the last populated row to a value, so that an additional check gets performed if an earlier row gets calculated, but this does not seem to work either :(
What I have is:
…
For Each a In activity_list
previousAddress = 0
If flagOffset > 0 Then
If rows_to_offset <> 0 Or flagsame > 0 Then
Set canda = a.Offset(rows_to_offset, 0) 'check if the offset is enough
If canda.Row <= lastR Then
Set a = Sheets("Sheet1").Cells(lastR + 1, 3) 'if not enough, go to the last result populated row
Else
Set a = canda
End If
rows_to_offset = 0
End If
End If
activityRow = a.Row
activityValue = a.Value
If activityValue <> 0 And Not activity_to_match_list.Find(activityValue, lookin:=xlValues) Is Nothing Then
Set found_act_match = activity_to_match_list.Find(activityValue, lookin:=xlValues)
Sheets("Sheet2").Activate
Set range_to_search_for_outputs = Sheets("Sheet2").Range(Cells(found_act_match.Row, 2), Cells(found_act_match.Row, 500))
If Not range_to_search_for_outputs.Find("o", lookat:=xlPart, lookin:=xlValues, SearchDirection:=xlNext) Is Nothing Then
Set found_output = range_to_search_for_outputs.Find("o", lookin:=xlValues, SearchDirection:=xlNext)
If found_output.Column <> 1
firstAddress = found_output.Address
Do
… do something with the output value…
' Then take the found output from the match and take its status from the Sheet1:
previousAddress = found_output.Address
If op <> "" Then
If Not op_list.Find(op, lookin:=xlValues) Is Nothing Then
Set found_output_match = op_list.Find(op, lookin:=xlValues)
Sheets("Sheet1").Activate
op_result = Cells(found_output_match.Row, "Y").Value
If Worksheets("Sheet1").Cells(activityRow + rows_to_offset, "Y").Value = "" Then
Worksheets("Sheet1").Cells(activityRow + rows_to_offset, "Y").Value = "? " & Format(op_result, "Percent")
lastR = Cells(activityRow + rows_to_offset, "Y").Row
End If
Else:
If Worksheets("Sheet1").Cells(activityRow + rows_to_offset, "Y").Value = "" Then
Worksheets("Sheet1").Cells(activityRow + rows_to_offset, "Y").Value = "Nothing in Sheet1"
lastR = Cells(activityRow + rows_to_offset, "Y").Row
End If
End If
Sheets("Sheet2").Activate
Set another = range_to_search_for_outputs.Find("o", after:=found_output, SearchDirection:=xlNext)
If Not another Is Nothing And another.Address <> found_output.Address Then 'if there is another output for the same activity, go to its output and continue as above
If another.Address <> firstAddress Then
Set found_output = another
Sheets("Sheet1").Activate
If Sheets("Sheet1").Cells(activityRow + rows_to_offset + 1, "C").Value <> activityValue Then 'if there isn't another row for the same activity yet
Sheets("Sheet1").Rows(activityRow + 1).Insert
Sheets("Sheet1").Cells(activityRow + 1, "C").Value = activityValue
rows_to_offset = rows_to_offset + 1
flagOffset = flagOffset + 1
Else:
flagsame = flagsame + 1 'if there is already another row for the same activity
rows_to_offset = rows_to_offset + 1
End If
End If
End If
Sheets("Sheet1").Activate
End If
Loop While (found_output.Address <> previousAddress) And (found_output.Address <> firstAddress)
End If
Else:
Worksheets("Sheet1").Cells(activityRow, "Y").Value = "no Output"
lastR = Cells(activityRow, "Y").Row
End If
ElseIf activity_to_match_list.Find(activityValue, lookin:=xlValues) Is Nothing Then
Worksheets("Sheet1").Cells(activityRow, "Y").Value = "Nothing in Sheet1"
lastR = Cells(activityRow, "Y").Row
ElseIf a.Offset(1, 0).Value <> 0 Then
Set a = a.Offset(1, 0)
Else:
Sheets("Sheet1").Activate
…
End If
Set … to Nothing
Next a
In principle use a dictionary with the key as the sheet2 activity and the value as a collection of row numbers for that activity. Scan down sheet1 and use the dictionary to find matching rows. Search along the matched row for cells with "o" and copy values back to sheet1 Column Y (inserting rows as required).
Sub FindOutputs()
Const COL_OUT = "Y"
Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, fnd As Range, sFirst As String
Dim dict As Object, key, count As Integer
Dim iLastRow As Long, i As Long, n As Long
Set dict = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook
' sheet 2 - Activities to Search in Column A
Set ws2 = wb.Sheets("Sheet2")
iLastRow = ws2.Cells(Rows.count, "A").End(xlUp).Row
For i = 1 To iLastRow
key = Trim(ws2.Cells(i, "A"))
If Len(key) > 0 Then
If Not dict.exists(key) Then
' collection holds row numbers for each activity
dict.Add key, New Collection
End If
dict(key).Add CStr(i) ' add row
End If
Next
' sheet 1 - Activities in column A
Set ws1 = wb.Sheets("Sheet1")
Set cell = ws1.Range("A1")
Do While Len(cell.value) > 0
key = Trim(cell.Value)
count = 0
' does activity exist on sheet2?
If dict.exists(key) Then
n = dict(key).count
' loop through matching rows
For i = 1 To n
r = dict(key).Item(i)
' search along the row for "o"
Set rng = ws2.Cells(r, "B").Resize(1, 500)
Set fnd = rng.Find("o", lookat:=xlPart, LookIn:=xlValues, SearchDirection:=xlNext)
If Not fnd Is Nothing Then
sFirst = fnd.Address
' do something with output value
Do
count = count + 1
If count > 1 Then
' insert row
cell.Offset(1).EntireRow.Insert _
CopyOrigin:=xlFormatFromLeftOrAbove
Set cell = cell.Offset(1)
cell.Value = key
End If
ws1.Range(COL_OUT & cell.Row).Value = fnd.Value
Set fnd = rng.FindNext(fnd)
Loop While fnd.Address <> sFirst
End If
Next
If count = 0 Then
ws1.Range(COL_OUT & cell.Row).Value = "No Output"
End If
Else
ws1.Range(COL_OUT & cell.Row).Value = "Nothing in Sheet1"
End If
Set cell = cell.Offset(1)
Loop
MsgBox "Done"
End Sub
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
I have 3 sheets that need to check if they have same value. All value on column B6 until last row should be same in Sheets MM, PP and CO. If there's difference value, the different value should be on highlight (the color is red).
But, my syntax didn't run. The syntax just can read if there's an empty column in range. This is my syntax.. Not including highlight. First, i tried to place the difference value to the other sheets. But, failed. Thank you.
Sub MatchValue()
Dim x As Integer
Dim y As Integer
Dim z As Integer
LastRowB = Cells(Rows.Count, "B").End(xlUp).Row
x = ActiveWorkbook.Worksheets("MM").Range("B6:B" & LastRowB).Cells.SpecialCells(xlCellTypeConstants).Count
y = ActiveWorkbook.Worksheets("PP").Range("B6:B" & LastRowB).Cells.SpecialCells(xlCellTypeConstants).Count
z = ActiveWorkbook.Worksheets("CO").Range("B6:B" & LastRowB).Cells.SpecialCells(xlCellTypeConstants).Count
If x <> y Then
MsgBox "MM <> PP", vbCritical, "Error Report"
End If
If y <> z Then
MsgBox "PP <> CO", vbCritical, "Error Report"
End If
If z <> x Then
MsgBox "CO <> MM", vbCritical, "Error Report"
End If
SheetMM = "MM"
DataColumnMM = "B6"
SheetPP = "PP"
DataColumnPP = "B6"
SheetCO = "CO"
DataColumnCO = "B6"
SheetUnmatched = "Data Unmatched"
DataColumnUnmatched = "A1"
DataRowMM = Range(DataColumnMM).Row
DataColMM = Range(DataColumnMM).Column
DataRowPP = Range(DataColumnPP).Row
DataColPP = Range(DataColumnPP).Column
DataRowCo = Range(DataColumnCO).Row
DataColCo = Range(DataColumnCO).Column
DataRowUnmatched = Range(DataColumnUnmatched).Row
DataColUnmatched = Range(DataColumnUnmatched).Column
LastDataMM = Sheets(SheetMM).Cells(Rows.Count, DataColMM).End(xlUp).Row
LastDataPP = Sheets(SheetPP).Cells(Rows.Count, DataColPP).End(xlUp).Row
LastDataCO = Sheets(SheetCO).Cells(Rows.Count, DataColCo).End(xlUp).Row
LastDataUnmathced = Sheets(SheetUnmatched).Cells(Rows.Count, DataColUnmatched).End(xlUp).Row
For counter = DataRowMM To LastDataRowMM
If WorksheetFunction.CountIf(LastDataPP, counter) = 0 Then
LastDataUnmathced.Offset(1) = counter
End If
Next
For counter = DataRowMM To LastDataRowMM
If WorksheetFunction.CountIf(LastDataCO, counter) = 0 Then
LastDataUnmathced.Offset(1) = counter
End If
Next
For counter = DataRowPP To LastDataRowPP
If WorksheetFunction.CountIf(LastDataCO, counter) = 0 Then
LastDataUnmathced.Offset(1) = counter
End If
Next
End Sub
Based on the information you've provided, you want to:
Check three tables across three sheets in the ActiveWorkbook
Check to see if the same number of constants exists in the table ranges
Highlight cells red where the values between the three sheets aren't the same
I've simplified the code in order to achieve these targets
Sub MatchValue()
Dim Range1 As Range, Range2 As Range, Range3 As Range
With ActiveWorkbook
With .Sheets("MM") 'First Sheet Name
Set Range1 = .Range("B6") 'Address of first row on First Sheet
Set Range1 = .Range(Range1, .Cells(.Rows.Count, Range1.Column).End(xlUp))
End With
With .Sheets("PP") 'Second Sheet Name
Set Range2 = .Range("B6") 'Address of first row on second Sheet
Set Range2 = .Range(Range2, .Cells(.Rows.Count, Range2.Column).End(xlUp))
End With
With .Sheets("CO") 'Third Sheet Name
Set Range3 = .Range("B6") 'Address of first row on third Sheet
Set Range3 = .Range(Range3, .Cells(.Rows.Count, Range3.Column).End(xlUp))
End With
End With
'Delete this part if you don't want to remove the existing fill (might be handy)
Range1.Interior.Pattern = xlNone
Range2.Interior.Pattern = xlNone
Range3.Interior.Pattern = xlNone
'Checks to see if the same number of constants exist within the test ranges
If Range1.SpecialCells(xlCellTypeConstants).Count <> _
Range2.SpecialCells(xlCellTypeConstants).Count Then
MsgBox "Range 1 and Range 2 constant count doesn't match", vbCritical, "Error Report"
ElseIf Range2.SpecialCells(xlCellTypeConstants).Count <> _
Range3.SpecialCells(xlCellTypeConstants).Count Then
MsgBox "Range 1 and Range 2 constant count doesn't match", vbCritical, "Error Report"
End If
Dim Temp1 As Variant, Temp2 As Variant, Temp3 As Variant, x As Long
'Checks to see if all the values entered are the same, if not, fills them red
Temp1 = Range1.Value
Temp2 = Range2.Value
Temp3 = Range3.Value
For x = 1 To UBound(Temp1, 1)
If Temp1(x, 1) <> Temp2(x, 1) Or _
Temp2(x, 1) <> Temp3(x, 1) Then
Range1.Cells(x, 1).Interior.Color = RGB(255, 0, 0)
Range2.Cells(x, 1).Interior.Color = RGB(255, 0, 0)
Range3.Cells(x, 1).Interior.Color = RGB(255, 0, 0)
End If
Next x
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 Excel Database which i just want to input only the tag number and i will automatic display the result in textbox... but in takes 30sec to display the result
Private Sub cmdSearch_Click()
Dim x As Long
Dim y As Long
x = Sheets("Clients").Range("A" & Rows.Count).End(xlUp).Row
For y = 1 To x
If Sheets("Clients").Cells(y, 1).Text = TextBox1.Value Then
TextBox1.Text = Sheets("Clients").Cells(y, 1)
TextBox4.Text = Sheets("Clients").Cells(y, 3)
TextBox5.Text = Sheets("Clients").Cells(y, 4)
TextBox10.Text = Sheets("Clients").Cells(y, 5)
TextBox11.Text = Sheets("Clients").Cells(y, 6)
TextBox12.Text = Sheets("Clients").Cells(y, 7)
TextBox13.Text = Sheets("Clients").Cells(y, 8)
End If
Next y
End Sub
Match is pretty fast
Private Sub cmdSearch_Click()
Dim m As VARIANT
With Sheets("Clients")
m = Application.Match(TextBox1.Value, .Columns(1), 0)
If not iserror(m) then
TextBox4.Text = .Cells(m, 3)
TextBox4.Text = .Cells(m, 4)
'etc
end if
end with
End Sub
Looping through 60,000 rows of data will be slow. Why don't you try Range.Find() instead? The documentation is here https://learn.microsoft.com/en-us/office/vba/api/excel.range.find
A sample code from that page is
With Worksheets(1).Range("a1:a500")
Set c = .Find(2, lookin:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing
End If
End With
In your code you could do something like the following. Declare a range variable and set it to the result of the find command. From the found range you can offset to the desired columns to retrieve their values.
dim result as range
x = Sheets("Clients").Range("A" & Rows.Count).End(xlUp).Row
set result = Sheets("Clients").Range("A1:A" & x).Find(TextBox1.Value, lookin:=xlValues)
if not result is nothing then
TextBox1.Text = result.value
TextBox4.Text = result.offset(0,2).value
' and so on. use offset to get results from other columns in the row where the found range is
end if