I have a problem with the following code. I have data in columns A and C and want to find matching pairs that are identical in these two columns (column A and C). The pairs should receive an unique identifier in column B and D. This way I can filter out corresponding pairs from column A and C and have two remaining columns that cannot be matched. However, my code keeps looping trough the data when there are duplicates within a column and keeps assigning higher reference numbers.
Sub match()
Dim c As Range, fn As Range, ref As Long
ref = 1
For Each c In Range("A2", Cells(Rows.Count, 1).End(xlUp))
If c <> "" And c <> 0 Then
Set fn = Range("C2", Cells(Rows.Count, 3).End(xlUp)).Find(c.Value, , xlValues, xlWhole)
If Not fn Is Nothing Then
adr = fn.Address
Do
If fn.Offset(, 1) = "" Then
c.Offset(, 1) = ref
fn.Offset(, 1) = ref
ref = ref + 1
Else
Set fn = Range("C2", Cells(Rows.Count, 3).End(xlUp)).FindNext(fn)
End If
Loop While fn.Address <> adr
End If
End If
Next
On Error Resume Next
Range("B2", Cells(Rows.Count, 1).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not found"
Range("D2", Cells(Rows.Count, 3).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not Found"
On Error GoTo 0
Err.Clear
End Sub
Does anyone know a solution?
You may benefit from MATCH in array form with Evaluate to fill the column D. The column B is the easy part, just MAX+1
Sub TEST()
Dim i As Long, j As Long
Dim rng_c As Range
Dim rng_b As Range
Dim LR As Long
Dim SR As Long
Dim Myf As WorksheetFunction
Set Myf = Application.WorksheetFunction 'to save some time typing
SR = 1 'starting row of data
LR = Range("A" & Rows.Count).End(xlUp).Row 'last row of data in column A
Set rng_b = Range("B" & SR & ":B" & LR) ' for column B
Set rng_c = Range("C" & SR & ":C" & LR) ' for column C
rng_b.Clear 'must be empty
Range("D" & SR & ":d" & LR).Clear 'must be empty
For i = SR To LR Step 1
If Myf.CountIf(rng_c, Range("A" & i).Value) = 0 Then
Range("B" & i).Value = "Not found"
Else
Range("B" & i).Value = Myf.Max(rng_b) + 1
End If
Next i
j = SR
For i = SR To LR Step 1
If Range("B" & i).Value <> "Not found" Then
j = Evaluate("MATCH(A" & i & ",C" & SR & ":C" & LR & "&D" & SR & ":D" & LR & ",0)")
Range("D" & j).Value = Range("B" & i).Value
End If
Next i
Set rng_b = Nothing
Set rng_c = Nothing
Set Myf = Nothing
End Sub
You could do this without VBA at all, actually.
In D2, write this Formula:
=IF(COUNTIFS($A:$A, $A2, $C:$C, $C2)>1, IF(COUNTIFS($A$1:$A2, $A2, $C$1:$C2, $C2)=1, MAX($D$1:$D1)+1, XLOOKUP($A2 & $C2, $A$1:$A1 & $C$1:$C1, $D$1:$D1)), "Not Found")
Then copy that down column D, and make column B equal to column D
There are several ways of doing this, but you were nearly there!
Here are some slight adjustments:
Sub match()
'''screenupdating false, calc to manual to speed up code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim c As Range, fn As Range, ref As Long
'setting your ranges for clarity
Dim rng As Range, rng2 As Range
Set rng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
Set rng2 = Range("C2", Cells(Rows.Count, 3).End(xlUp))
'''necessary for rerunning
rng.Offset(0, 1).ClearContents
rng2.Offset(0, 1).ClearContents
ref = 1
For Each c In rng
If c <> "" And c <> 0 Then
'adding After:=rng2.Cells.Count
Set fn = rng2.Find(c.Value, rng2.Cells(rng2.Cells.Count), xlValues, xlWhole)
If Not fn Is Nothing Then
''' placed this back here
adr = fn.Address
Do
'''
'place inside Do ... Loop While
'''adr = fn.Address
'''
If fn.Offset(, 1) = "" Then
c.Offset(, 1) = ref
fn.Offset(, 1) = ref
ref = ref + 1
''' but we do need it here to get out of infinite loop
''' in case
adr = fn.Address
Else
Set fn = rng2.FindNext(fn)
End If
Loop While fn.Address <> adr
End If
End If
Next
On Error Resume Next
Range("B2", Cells(Rows.Count, 1).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not found"
Range("D2", Cells(Rows.Count, 3).End(xlUp).Offset(, 1)).SpecialCells(xlCellTypeBlanks) = "Not found" '''minor correction: "Not found" (F -> f)
On Error GoTo 0
Err.Clear
'''screenupdating true again, calc to auto
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Problem 1: you forget to add the After parameter in .Find(...). See Using the .Find Function VBA - not returning the first value on why you need it.
Problem 2: the statement adr = fn.Address should be inside the Do ... Loop While, else you won't step out of the loop until after the last match; as a result you just kept overwriting the value in c.Offset(, 1) for A8 (leading to 6) and adding values for all its matches in column C (which explains values 4, 5, 6).
Edit: Problem 2 in the strikethrough text above was real, my suggestion on how to fix it quite ignorant. It will cause an infinite loop for a duplicate in rng that does have one or more matches in rng2, but less matches than its own count in rng. E.g. if rng has x 3 times, and rng2 has x twice, the code will loop forever when it gets to the 3rd x and crash Excel. So sorry. Pure luck that the dummy data didn't contain such an example.
Correct solution: keep adr = fn.Address were it was, but add the same statement inside the If fn.Offset(, 1) = "" Then statement. Now, it should work. Code above updated. Triple apostrophes in the code indicate corrections. Added some minor syntax for better performance.
However, as I was testing on a much larger set, I noticed this code was slow. I've found a rather different solution with much better performance, which I will post as a different answer in a sec (in accordance with SO etiquette.
In my other answer I focused on improving your initial code, since you almost got there yourself, and I think one should encourage people's efforts. However, on a larger set, performance wasn't great, so I had a look to see if we could find improvement with a different method. The answer, I think, is "yes". The following solution stores the values from rng2 in an array and on every match alters that match within the array (by adding Chr(1) & ref to the init value). At the end we use another loop to populate rng2.Offset(,1) with the refs through Split()(1) . This way, each new match will simply be the correct match for the new pair, thus avoiding many unnecessary .find commands. Below comparison of 2 tests.
In this snippet "Find_method" refers to code in other answer, "Array_method" refers to answer below.
I'd say, we have ourselves a clear winner. Suggestions for further improvement are of course welcome! Code as follows, with added comments to explain what it does:
Sub matchPairs()
'screenupdating false, calc to manual to speed up code
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim c As Range, fn As Range
Dim ref As Long, c_match As Long, i As Long
Dim rng As Range, rng2 As Range
'set ranges
Set rng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
Set rng2 = Range("C2", Cells(Rows.Count, 3).End(xlUp))
'clear offsets (not strictly necessary for rerun)
rng.Offset(0, 1).ClearContents
rng2.Offset(0, 1).ClearContents
'drop rng2 inside array
Dim DirArray() As Variant
DirArray = Application.Transpose(rng2.Value)
ref = 1 'counter
'looping through init rng
For Each c In rng
'get position match c.Value in DirArray; will throw error if no match
On Error Resume Next
c_match = Application.match(c.Value, DirArray, 0)
'handle error
If Err.Number <> 0 Then
c_match = 0
'reset error handling
Err.Clear
On Error GoTo 0
End If
If c_match = 0 Then
'no match
c.Offset(, 1) = "Not found"
Else
'assign counter
c.Offset(, 1) = ref
'alter match in array, so it won't show up as a match again
'Chr(1) (Start of Header, non-printable ASCII char) won't occur in your data
'we can use it as the delimiter for Split below
DirArray(c_match) = DirArray(c_match) & Chr(1) & ref
'increment counter
ref = ref + 1
End If
Next
'loop over array, and check for presence Chr(1) in each value
For i = LBound(DirArray) To UBound(DirArray)
If InStr(DirArray(i), Chr(1)) = 0 Then
'we didn't alter this entry: it was never found
rng2.Cells(i).Offset(, 1) = "Not found"
Else
'Chr(1) present, get second value from Split array, and put in the offset
rng2.Cells(i).Offset(, 1) = Split(DirArray(i), Chr(1))(1)
End If
Next i
'screenupdating true again, calc to auto
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Hi I'm trying to create a VBA code that fills the entire column G values with Column E - Column F (so E2-F2 = G2) but I keep getting mismatch error. The values start from the second row and I have created a loop to run down the columns.
This is the code I have so far.
Sub RemainingHours()
Dim i As Integer
i = 2
With Sheets("Opt")
While Not IsEmpty(Cells(5, i).Value)
Cells(7, i).Value = Cells(6, i).Value - Cells(5, i).Value
i = i + 1
Wend
End With
End Sub
Thank you!
Rather than looping you could try using Evaluate.
Sub RemainingHours()
Dim rng As Range
Dim Res As Variant
With Sheets("Opt")
Set rng = .Range("E2", .Range("E" & Rows.Count).End(xlUp))
End With
Res = Evaluate(rng.Offset(, 1).Address & "-" & rng.Address)
rng.Offset(, 2).Value = Res
End Sub
I want to create a userform that can find the "Sales" value in column E and then input the remaining data to the same row.
Set APAC = Sheet2
APAC.Activate
Range("E18:E1888").Select
For Each D In Selection
If D.Value = "TWO.Sales.Value" Then
Exit For
End If
Next D
Rows(D.Row).Select
D.Offset(0, 2).Value = TWO.RSA.Value
D.Offset(0, 3).Value = TWO.Part.Value
D.Offset(0, 4).Value = Application.WorksheetFunction.VLookup(TWO.Part.Value, Worksheets("DataEntry").Range("T2:U70").Value, 2, False)
D.Offset(0, 5).Value = TWO.Program.Value
D.Offset(0, 6).Value = TWO.QTY.Value
Sheet2.Activate
This is my code but
run time error '91'
occurs.
I am having error on the "Rows(D.Row).select" line – Jacob 2 mins ago
That means "TWO.Sales.Value" was not found in Range("E18:E1888") and hence D was nothing. You need to check if the value was found. Also I have a feeling that you wanted If D.Value = TWO.Sales.Value Then instead of If D.Value = "TWO.Sales.Value" Then
Also there is no need to Select/Activate. You can directly work with the objects. You may want to see How to avoid using Select in Excel VBA
Whenever you are working with VLookup, it is better to handle the error that may pop up when a match is not found. There are various ways to do it. I have shown one way in the code below.
Is this what you are trying? (UNTESTED)
Option Explicit
Sub Sample()
Dim APAC As Worksheet
Dim curRow As Long
Dim aCell As Range
Dim Ret
Set APAC = Sheet2
With APAC
For Each aCell In .Range("E18:E1888")
If aCell.Value = TWO.Sales.Value Then
curRow = aCell.Row
Exit For
End If
Next aCell
If curRow = 0 Then
MsgBox "Not Found"
Else
.Range("G" & curRow).Value = TWO.RSA.Value
.Range("H" & curRow).Value = TWO.Part.Value
On Error Resume Next
Ret = Application.WorksheetFunction.VLookup(TWO.Part.Value, _
Worksheets("DataEntry").Range("T2:U70").Value, 2, False)
On Error GoTo 0
If Ret <> "" Then .Range("I" & curRow).Value = Ret
.Range("J" & curRow).Value = TWO.Program.Value
.Range("K" & curRow).Value = TWO.QTY.Value
End If
End With
End Sub
NOTE: If the range .Range("E18:E1888") is dynamic then you may want to find the last row as shown HERE and then use the range as .Range("E18:E" & LastRow)
so i have Sheet1 that is use to contain the list of my inventory data. what i want to do is in another sheet(Sheet2). i can search my Sheet1 data and display the data there ( for example when i type cheetos, only the cheetos item got display ). Help me guys, using VBA is okay or other method is also fine.
If your results don't have to be on a different sheet, you could just convert your data to a Table. Select Cells A1:D8 and click on Insert -> Table. Make sure "My table has headers" is clicked and voila!
Once formatted as a table, you can filter Product ID however you need.
If you do need to show these results in another sheet, VBA would be my go-to solution. Maybe something like this:
Public Sub FilterResults()
Dim findText As String
Dim lastRow As Long
Dim foundRow As Long
Dim i As Long
'If there's nothing to search for, then just stop the sub
findText = LCase(Worksheets("Sheet2").Range("D4"))
If findText = "" Then Exit Sub
'Clear any old search results
lastRow = Worksheets("Sheet2").Cells(Rows.Count, 4).End(xlUp).Row
If lastRow > 5 Then
For i = 6 To lastRow
Worksheets("Sheet2").Range("C" & i).ClearContents
Worksheets("Sheet2").Range("D" & i).ClearContents
Worksheets("Sheet2").Range("E" & i).ClearContents
Worksheets("Sheet2").Range("F" & i).ClearContents
Next i
End If
'Start looking for new results
lastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
foundRow = 6
For i = 2 To lastRow
If InStr(1, LCase(Worksheets("Sheet1").Range("B" & i)), findText) <> 0 Then
Worksheets("Sheet2").Range("C" & foundRow) = Worksheets("Sheet1").Range("A" & i)
Worksheets("Sheet2").Range("D" & foundRow) = Worksheets("Sheet1").Range("B" & i)
Worksheets("Sheet2").Range("E" & foundRow) = Worksheets("Sheet1").Range("C" & i)
Worksheets("Sheet2").Range("F" & foundRow) = Worksheets("Sheet1").Range("D" & i)
foundRow = foundRow + 1
End If
Next i
'If no results were found, then open a pop-up that notifies the user
If foundRow = 6 Then MsgBox "No Results Found", vbCritical + vbOKOnly
End Sub
I would recommend avoiding VBA for this process as it can be done easily with excel's functions. If you would like to do it via VBA one could just loop through the list of products and find a key word, adding it to an array if the "Cheetos" is contained in the specific cell value using a wildcard like so:
This could be modified to run upon the change of the D4 cell if needed, and of course some modifications could be done to ensure that formatting etc can be done to your liking.
Sub test()
Dim wb As Workbook
Dim rng As Range, cell As Range
Dim s_key As String, s_find() As String
Dim i As Long
Set wb = Application.ThisWorkbook
Set rng = wb.Sheets("Sheet1").Range("B2:B8")
s_key = wb.Sheets("Sheet2").Range("D4").Value
wb.sheets("Sheet2").Range("C6:F9999").clearcontents
i = 0
For Each cell In rng
If cell.Value Like "*" & s_key & "*" Then
ReDim Preserve s_find(3, i)
s_find(0, i) = cell.Offset(0, -1).Value
s_find(1, i) = cell.Value
s_find(2, i) = cell.Offset(0, 1).Value
s_find(3, i) = cell.Offset(0, 2).Value
i = i + 1
End If
Next cell
wb.Sheets("Sheet2").Range("C6:F" & 5 + i).Value = Application.WorksheetFunction.Transpose(s_find)
End Sub
I found the following code to hide duplicate rows:
For i = Last_Row To First_Row Step -1
If WorksheetFunction.CountIf(Range("F" & First_Row & ":F" & i), Range("F" & i).Value) > 1 Then Rows(i).Hidden = True
Next I
The code works great, but I'm using it in a Table so I'd like to replace the fixed column "F" with a table header reference. That way if someone inserts columns it will still work. I'm struggling to find the right syntax.
My table and column is:
Range("PART_SELECTION_DATABASE[PART '#]")
Any help is appreciated.
You can use Find function to look for the header PART '#".
Once it's found, you can extract the column number using FindRng.Column.
Code
Option Explicit
Sub FindHeader()
Dim FindRng As Range
Dim HeadrStr As String
Dim Col As Long
HeadrStr = "PART '#"
Set FindRng = Cells.Find(what:=HeadrStr)
If Not FindRng Is Nothing Then . make sure Find was successful
Col = FindRng.Column ' get the column number
Else ' Find failed to find the Header
MsgBox "unable to find " & HeadrStr, vbCritical
Exit Sub
End If
For I = Last_Row To First_Row Step -1
If WorksheetFunction.CountIf(Range(Cells(First_Row, Col), Cells(I, Col)), Cells(I, Col).Value) > 1 Then Rows(I).Hidden = True
Next I
End Sub