Advanced INDEX-MATCH - excel

In my workbook I have 2 worksheets: Sheet1 and Sheet2.
In Sheet1 I have the following data set:
In Sheet2 I have the following data set:
I need to create a code that will do the following:
Populate the score columns ("Score of SpeGro", "Score of PrimSpe", etc.)
For example, for the "Score of SpeGro" column it needs to:
Search in Sheet1 the column header corresponding to SpeGro (in this case it's column 4);
The values of column 4 need to match the values in column 3 of Sheet2.
Only consider the values in Sheet2 with the DIMENSION "SpeGro" (in this case);
Only consider the values with PrdInd (Sheet1) = PrdInd (Sheet2).
Extra info: I have a INDEX-MATCH formula that works if I only had DIMENSION:
For k = 2 To RowNum
tWb.Sheets("Sheet1").Cells(k, 6).Value = Application.IfError(Application.Index(tWb.Sheets("Sheet2").Range("D:D"), Application.Match(tWb.Sheets("Sheet1").Cells(k, 4), tWb.Sheets("Sheet2").Range("C:C"), 0)), 0)
Next k
Any idea on how I can achieve this?

This is just to give you an idea on how you can tackle this task. But the code is working if you want to try it.
'task: Populate the score columns ("Score of SpeGro", "Score of PrimSpe", etc.)
'if conditions are met
Sub Whatever()
Dim strSearch As String
Dim aCell As Range
Dim col_n As Integer
Dim last_row As Long
Dim first_row As Byte
Dim Count As Long
'Search in Sheet1 the column header corresponding to
'"Score of SpeGro" (in this case it's column 6)
'CONFIG
'-------------
strSearch = "Score of SpeGro"
first_row = 2 'first row of the data sets in sheet 1 and 2
'-------------
Set aCell = Sheet1.Rows(1).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
col_n = aCell.Column
'column numbers sheet1
'Scoreof PrimSpe column numner = col_n +1
'SpeGro column number = col_n - 2
'Prdlnd column number = col_n - 5
last_row = Sheets("Sheet1").Cells(Rows.Count, col_n - 5).End(xlUp).Row
For Count = first_row To last_row
If Sheets("Sheet1").Cells(Count, col_n - 2) = Sheets("Sheet2").Cells(Count, 3) _
And Sheets("Sheet2").Cells(Count, 2) = "SpeGro" _
And Sheets("Sheet1").Cells(Count, col_n - 5) = Sheets("Sheet2").Cells(Count, 1) Then
Sheets("Sheet1").Cells(Count, col_n) = "Put something here"
End If
Next Count
End Sub

Option Explicit
Sub Button1_Click()
'task: Populate the score columns ("Score of SpeGro", "Score of PrimSpe", etc.)
'if conditions are met
Dim strSearch1 As String, strSearch2 As String
Dim aCell1 As Range, aCell2 As Range
Dim col_n1 As Integer, col_n2 As Integer
Dim last_row1 As Long, last_row2 As Long
Dim first_row As Byte
Dim Count As Long
Dim myArray As Variant, element As Variant
'Search in Sheet1 the column header corresponding to
'"Score of SpeGro" (in this case it's column 6)
myArray = Array("Specialty Grouping", "Primary Specialty")
'strSearch1 = "Score of Specialty Grouping"
'strSearch2 = "Specialty Grouping"
For Each element In myArray
Set aCell1 = Sheet1.Rows(1).Find(What:="Score of " & element)
Set aCell2 = Sheet1.Rows(1).Find(What:=element)
col_n1 = aCell1.Column
col_n2 = aCell2.Column
'column numbers sheet1
'SpeGro column number = col_n2
last_row1 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
last_row2 = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
'The values of col_n2 need to match the values in column 3 of USER_INPUTS.
For Count = 2 To last_row1
Sheets("Sheet1").Cells(Count, col_n1) = Application.Index(ThisWorkbook.Sheets("Sheet2").Range("D2:D" & last_row2), _
Application.Match(ThisWorkbook.Sheets("Sheet1").Cells(Count, 1), ThisWorkbook.Sheets("Sheet2").Range("A2:A" & last_row2), 0) * _
Application.Match(ThisWorkbook.Sheets("Sheet1").Cells(1, col_n2), ThisWorkbook.Sheets("Sheet2").Range("B2:B" & last_row2), 0) * _
WorksheetFunction.IfError(Application.Match(ThisWorkbook.Sheets("Sheet1").Cells(Count, col_n2), ThisWorkbook.Sheets("Sheet2").Range("C2:C" & last_row2), 0), 0))
Next Count
Next element
End Sub

Related

Loop through column matching data in workbook and return a value

I have been trying to adapt the following code to
Loop through column A of Sheet 1 and for each value in column A search the whole workbook for it's matching value (which will be found in another sheet also in column A). When a match is found, return the value found in the same row but from column F.
Sub Return_Results_Entire_Workbook()
searchValueSheet = "Sheet2"
searchValue = Sheets(searchValueSheet).Range("A1").Value
returnValueOffset = 5
outputValueSheet = "Sheet2"
outputValueCol = 2
outputValueRow = 1
Sheets(outputValueSheet).Range(Cells(outputValueRow, outputValueCol), Cells(Rows.Count, outputValueCol)).Clear
wsCount = ActiveWorkbook.Worksheets.Count
For I = 1 To wsCount
If I <> Sheets(searchValueSheet).Index And I <> Sheets(outputValueSheet).Index Then
'Perform the search, which is a two-step process below
Set Rng = Worksheets(I).Cells.Find(What:=searchValue, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
rangeLoopAddress = Rng.Address
Do
Set Rng = Sheets(I).Cells.FindNext(Rng)
Sheets(outputValueSheet).Cells(Cells(Rows.Count, outputValueCol).End(xlUp).Row + 1, outputValueCol).Value = Sheets(I).Range(Rng.Address).Offset(0, returnValueOffset).Value
Loop While Not Rng Is Nothing And Rng.Address <> rangeLoopAddress
End If
End If
Next I
End Sub
The code above works but only for the first row of data on Sheet1.
Any help would be greatly appreciated!
You can create an array of arrays where each index of main array would be the dataset A:F from each worksheet:
Sub test()
Dim WK As Worksheet
Dim LR As Long
Dim i As Long
Dim j As Long
Dim MasterArray() As Variant
Dim WkArray As Variant
'create master aray
ReDim MasterArray(1 To ThisWorkbook.Worksheets.Count - 1) 'As many indexes as worksheets -1 (because master sheet does not count)
i = 1
For Each WK In ThisWorkbook.Worksheets
If WK.Name <> "Hoja1" Then 'exclude master sheet witch search values
LR = WK.Range("A" & WK.Rows.Count).End(xlUp).Row 'last non-blank row
WkArray = WK.Range("A1:F" & LR).Value 'take all values in A:F to singlearray
MasterArray(i) = WkArray
Erase WkArray
i = i + 1
End If
Next WK
'now in Master array you have in each index all the values
' as example, if you call MasterArray(1)(1, 1) it will return cell value A1 from first worksheet
Set WK = ThisWorkbook.Worksheets("Hoja1") 'master sheet witch search values
With Application.WorksheetFunction
LR = WK.Range("A" & WK.Rows.Count).End(xlUp).Row 'last non-blank row
For i = 1 To LR Step 1 'for each row in master sheet until last non blank
For j = 1 To UBound(MasterArray) Step 1 'for each dataset in masterarray
WkArray = Application.Transpose(Application.Index(MasterArray(j), , 1)) 'first column of dataset (A column)
If IsError(Application.Match(WK.Range("A" & i).Value, WkArray, 0)) = False Then 'if value exists get F
WK.Range("B" & i).Value = .VLookup(WK.Range("A" & i).Value, MasterArray(j), 6, 0)
Erase WkArray
Exit For
End If
Erase WkArray
Next j
Next i
End With
Erase MasterArray
Set WK = Nothing
End Sub
The code first creates the main array named MasterArray. Then it loops trough each value on column A from Master Sheet (named Hoja1 in my example) and checks if the value exists in each subarray. If it does then returns columns F from dataset and keep looping.
After executing code I get this output:
Notice value 2 returns nothing because it does not exist in any of the other sheets.

Use string in column to find a word match in table to assign value

I have a lookup table of data in Sheet1 where all the names in columns A and B will be unique, so no names in either A will exist in B and vice-versa. However, some names could include special characters like a hyphen or dash such as O'neil or Jamie-lee
I have another table of data in Sheet2, in which I need to use the text string in column D to find a matching name in Sheet1 (in either column A or B) and then assign the Score value of the row on sheet1 if a match is found into Sheet2 column E.
I have entered the matched score values in column E to demonstrate the outcome I require.
I don't mind using VBA or an Excel formula that works in XL2010
Is it possible to use a text string to find a word match, as I've only seen it the other way around, or am I looking at this the wrong way? I just don't seem to be getting anywhere.
I have change the code so often now trying to get it to work, I think I'm a bit lost, but this is the current state of my code that isn't working:
Sub TextSearch()
Dim LR As Long
LR = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Dim xLR As Long
xLR = ThisWorkbook.Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Dim oSht As Worksheet
Dim Lastrow As Long
Dim strSearch As String, Score As String
Dim aCell As Range
Dim i As Integer
Set oSht = Sheets("Sheet1")
Lastrow = oSht.Range("A" & Rows.Count).End(xlUp).Row
With Sheets("Sheet2")
'Loop from Lastrow to Firstrow (bottom to top)
For Lrow = xLR To 2 Step -1
'Get the value in the D column to perform search on
With .Cells(Lrow, "D")
If Not IsEmpty(.Value) Then
strSearch = .Value
Set aCell = oSht.Range("A1:B" & Lastrow).Find(What:=strSearch, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
For i = 2 To Lastrow
'Lookin column A on sheet1
If oSht.Cells(i, 1).Value = aCell Then
Score = oSht.Cells(i, 1).Offset(0, 2).Value
Sheets("Sheet2").Cells(Lrow, 4).Offset(0, 1).Value = Score
'Lookin Column B on sheet1
ElseIf oSht.Cells(i, 2).Value = aCell Then
Score = oSht.Cells(i, 2).Offset(0, 1).Value
Sheets("Sheet2").Cells(Lrow, 4).Offset(0, 1).Value = Score
End If
Next i
End If
End With
Next Lrow
End With
End Sub
This should do what you are attempting using a dictionary. It creates keys based off of Columns A and B on Sheet 1 with their scores stored as the item.
If you have duplicate names in Sheet 1 this won't fail, but it will only match against the first name encountered. There isn't enough data for it to make a distinction that I can see.
Sub findmatches()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim dict As Object
Dim i As Long
Dim lr As Long
Dim name As String
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set dict = CreateObject("Scripting.Dictionary")
With ws1
lr = .Cells(.Rows.Count, 1).End(xlUp).Row 'Getting last row
For i = 2 To lr
If Not dict.exists(.Cells(i, 1).Value) Then 'Checking if name is in dictionary
dict.Add .Cells(i, 1).Value, .Cells(i, 3).Value 'Adding name and score
End If
If Not dict.exists(.Cells(i, 2).Value) Then 'Checking if name is in dictionary
dict.Add .Cells(i, 2).Value, .Cells(i, 3).Value 'Adding name and score
End If
Next i
End With
With ws2
lr = .Cells(.Rows.Count, 4).End(xlUp).Row
For i = 2 To lr
name = Split(.Cells(i, 4).Value, " ")(0) 'Splitting the string into an array and taking the first element
If dict.exists(name) Then 'Checking if name is in dict
.Cells(i, 5).Value = dict(name) 'assigning score to Column 5
Else
.Cells(i, 5).Value = 0 'No name score = 0
End If
Next i
End With
End Sub
In Excel 365, this is possible via an (extended) array formula. Paste into E2 and copy down.
=LET(lookup,Sheet1!$C$2:$C$5,delimiter," ",string,$D2,array,Sheet1!$A$2:$B$5,data,INDEX(array,MOD(SEQUENCE(ROWS(array)*COLUMNS(array),,0),ROWS(array))+1,ROUNDUP(SEQUENCE(ROWS(array)*COLUMNS(array))/ROWS(array),0)),values,FILTERXML("<t><s>"&SUBSTITUTE(string,delimiter,"</s><s>")&"</s></t>","//s"),list,IFERROR(INDEX(lookup,1+MOD(MATCH(values,data,0)-1,ROWS(array))),0),TRANSPOSE(FILTER(list,list<>0)))
Breaking this down
=LET(lookup, Sheet1!$C$2:$C$5,
delimiter, " ",
string, $D2,
array, Sheet1!$A$2:$B$5,
data, INDEX(array,MOD(SEQUENCE(ROWS(array)*COLUMNS(array),,0),ROWS(array))+1,ROUNDUP(SEQUENCE(ROWS(array)*COLUMNS(array))/ROWS(array),0)),
values, FILTERXML("<t><s>"&SUBSTITUTE(string, delimiter,"</s><s>")&"</s></t>","//s"),
list, IFERROR(INDEX(lookup,1+MOD(MATCH(values,data,0)-1,ROWS(array))),0),
TRANSPOSE(FILTER(list, list<>0))
)
Assign:
lookup as the lookup range to take the values for the results
delimiter and string as the sentence to test and how to split it for a dynamic array
array as the data lookup array to test
data is a calculated 1D array of all values from array stacked
values is a calculated 1D array from your sentence to test
list is then an array of the row 'indices' where matches are found (mod #rows so it's column independent)
Finally, that list is filtered of any non-hits then transposed to give a spill list of all the matches from the lookup values.

Check if all column values exists in another list

The excel vba macro I have created goes through an entire column and searches each value in the column against another column found on another worksheet. I have a T/F column where I mark down "T" if it is found, "F" if it is not found. However, I feel like the way I am doing it might not be very efficient, as the macro takes about 30 minutes to go through 31,000 rows of values to be searched from another column with about 27,000 number of values.
For a simple illustration, I have included a few images which explains what the macro does.
Initially the T/F column will be empty. Only after executing the macro, would it be filled. I loop through each row in column A and try to find the value against the SearchCol in the next picture.
Here is the vba code I am currently using.
Sub CheckIfValuesExist()
Dim ActiveWS As Worksheet, WS2 As Worksheet
Dim ValueColLetter As String, SearchColLetter As String, TFColLetter As String
Dim LastRow As Long, i As Long
Dim target As Variant, rng As Range
Set ActiveWS = ActiveWorkbook.Worksheets(1)
Set WS2 = ActiveWorkbook.Worksheets(2)
ValueColLetter = "A"
SearchColLetter = "A"
TFColLetter = "B"
LastRow = ActiveWS.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, _
LookIn:=xlFormulas).Row
For i = 2 To LastRow
target = ActiveWS.Range(ValueColLetter & i).Value
If target <> "" Then
With WS2.Range(SearchColLetter & ":" & SearchColLetter) 'searches all of column A
Set rng = .Find(What:=target, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
ActiveWS.Range(TFColLetter & i).Value = "T" 'value found
Else
ActiveWS.Range(TFColLetter & i).Value = "F" 'value not found
End If
End With
End If
Next i
End Sub
The macro works as intended, I just find it to be slow. Is there any better way to do the same thing but in a quicker manner?
Check Column Against Column
Array Match Range Version
Sub CheckIfValuesExist()
Const cSheet1 As Variant = 1 ' Value Worksheet Name/Index
Const cSheet2 As Variant = 2 ' Search Worksheet Name/Index
Const cFirst As Long = 2 ' First Row
Const cVal As Variant = "A" ' Value Column
Const cSrc As Variant = "A" ' Search Column
Const cTF As Variant = "B" ' Target Column
Const cT As String = "T" ' Found String
Const cF As String = "F" ' Not Found String
Dim RngS As Range ' Search Range
Dim vntV As Variant ' Value Array
Dim vntT As Variant ' Target Array
Dim LastV As Long ' Value Last Column Number
Dim LastS As Long ' Search Last Column Number
Dim i As Long ' Value/Target Row Counter
Dim dummy As Long ' Match Dummy Variable
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
On Error GoTo ProcedureExit
With ThisWorkbook.Worksheets(cSheet1)
LastV = .Columns(.Cells(1, cVal).Column).Find("*", , -4123, , 2, 2).Row
vntV = .Range(.Cells(cFirst, cVal), .Cells(LastV, cVal))
End With
With ThisWorkbook.Worksheets(cSheet2)
LastS = .Columns(.Cells(1, cSrc).Column).Find("*", , -4123, , 2, 2).Row
Set RngS = .Range(.Cells(cFirst, cSrc), .Cells(LastS, cSrc))
ReDim vntT(1 To UBound(vntV), 1 To 1)
For i = 1 To UBound(vntV)
On Error Resume Next
If vntV(i, 1) <> "" Then
dummy = Application.Match(vntV(i, 1), RngS, 0)
If Err Then
vntT(i, 1) = cF
Else
vntT(i, 1) = cT
End If
End If
On Error GoTo 0
Next
End With
On Error GoTo ProcedureExit
With ThisWorkbook.Worksheets(cSheet1)
.Range(.Cells(cFirst, cTF), .Cells(.Rows.Count, cTF)).ClearContents
.Cells(cFirst, cTF).Resize(UBound(vntT)) = vntT
End With
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
Let us assume that data included in Sheet 1.
Try:
Option Explicit
Sub VlookUp()
Dim LastRowSV As Long, LastRowV As Long, Counts As Long
Dim wsName As String
Dim wsListSV As Range, cellSV As Range, wsListV As Range, cellV As Range
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of Search Values
LastRowSV = .Cells(.Rows.Count, "D").End(xlUp).Row
'Find the last row of Values
LastRowV = .Cells(.Rows.Count, "A").End(xlUp).Row
'Set the list with the Search Values
Set wsListSV = .Range(Cells(2, 4), Cells(LastRowSV, 4))
'Set the list with the Values
Set wsListV = .Range(Cells(3, 1), Cells(LastRowV, 1))
'Loop each value in Search Values
For Each cellV In wsListV
Counts = Application.WorksheetFunction.CountIf(wsListSV, cellV)
If Counts <> 0 Then
cellV.Offset(0, 1).Value = "T"
Else
cellV.Offset(0, 1).Value = "F"
End If
Next
End With
End Sub
Result:
Why don't you use the MATCH formula?
If your values are in Col A and the search values are at
the cells $F$5:$F$10 the formula is:
=MATCH(A2,$F$5:$F$10,0)
or if you insist on a T/F result:
=IF(ISERROR(MATCH(A2,$F$5:$F$10,0)),"T","F")
Of cause you can insert this formula also with a macro.

Find a cells value (text) based on two criteria

I've spent the majority of my afternoon looking for a way to return a text value in a cell based on two columns. I'm looking to match a values from Sheet1, columns A & F to sheet2, returning the value in column B where these two match into sheet 1.
To visualize:
Sheet 1 Sheet 2
A F A B F
x b x c y
x g x k b
Is there a way to use VLOOKUP to do this that I missed? I'm pretty confident that I'm missing something simple, but it's giving me a hard time.
Thanks in advance!
The following Subscript does exactly what you asked:
Sub DoThaThing()
Dim i As Long, lastRow1 As Long
Dim Sheet1A As Variant, Sheet1F As Variant, firstFound As String
Dim findData As Range
lastRow1 = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRow1 Step 1
Sheet1A = Sheets("Sheet1").Cells(i, "A").Value
Sheet1F = Sheets("Sheet1").Cells(i, "F").Value
Set findData = Sheets("Sheet2").Columns("A:A").Find(What:=Sheet1A, _
After:=Sheets("Sheet2").Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not findData Is Nothing Then
'First instance found, loop if needed
firstFound = findData.Address
Do
'Found, check Column F (5 columns over with offset)
If findData.Offset(0, 5).Value = Sheet1F Then
'A and F match get data from B (1 column over with offset)
Sheets("Sheet1").Cells(i, "B").Value = findData.Offset(0, 1).Value
Exit Do
Else
'F doesnt match, search next and recheck
Set findData = Sheets("Sheet2").Columns("A:A").FindNext(findData)
End If
Loop While Not findData Is Nothing And firstFound <> findData.Address
Else
'Value on Sheet 1 Column A was not found on Sheet 2 Column A
Sheets("Sheet1").Cells(i, "B").Value = "NOT FOUND"
End If
Next
End Sub
Edit: Infinite Loop Fixed.
try this code, it's work for me :
Option Explicit
Sub test()
' Active workbook
Dim wb As Workbook
Set wb = ThisWorkbook
Dim i As Long
Dim j As Long
'*******************************************
'Adapt this vars
'define your sheets
Dim ws_1 As Worksheet
Dim ws_2 As Worksheet
Set ws_1 = wb.Sheets("Feuil1") 'change name of the sheet to complete
Set ws_2 = wb.Sheets("Feuil2") 'change name of the sheet with all data
'definie the last Rows
Dim lastRow_ws1 As Long
Dim lastRow_ws2 As Long
lastRow_ws1 = ws_1.Range("A" & Rows.Count).End(xlUp).Row + 1 'if you need, adjust column to find last row
lastRow_ws2 = ws_2.Range("A" & Rows.Count).End(xlUp).Row + 1 'if you need, adjust column to find last row
'*******************************************
Dim keyMach1 As String
Dim keyMach2 As String
For j = 1 To lastRow_ws1
For i = 1 To lastRow_ws2
Dim keySearch As String
Dim keyFind As String
keySearch = ws_1.Cells(j, 1).Value & ws_1.Cells(j, 6).Value 'I concat both cell to create o key for the search
keyFind = ws_2.Cells(i, 1).Value & ws_1.Cells(i, 6).Value ' idem to match
If keySearch = keyFind Then
ws_1.Cells(j, 2).Value = ws_2.Cells(i, 2).Value
End If
Next i
Next j
End Sub

VBA for duplicate rows

I have a sheet of columns.
I want to compare data in multiple columns, and return a flag in another column to indicate rows that are duplicates. I found a little code online which was meant for checking one column of data, and have so far been unsuccessful in being able to tweek it for multiple columns. The final code will need to look at specific columns which I will define later however for the moment say the sheet is as follows:
StaffNumber CallType
1 A
2 B
1 A
4 D
5 E
6 F
7 G
8 H
1 A
2 C
1 Z
6 P
The Col A is labelled Staff Number. Col B is labelled CallType. In Col C I want the flag to be entered against the row.
My Code is as follows:
Sub DuplicateIssue()
Dim last_StaffNumber As Long
Dim last_CallType As Long
Dim match_StaffNumber As Long
Dim match_CallType As Long
Dim StaffNumber As Long
Dim CallType As Long
last_StaffNumber = Range("A65000").End(xlUp).Row
last_CallType = Range("B65000").End(xlUp).Row
For StaffNumber = 1 To last_StaffNumber
For CallType = 1 To last_CallType
'checking if the Staff Number cell is having any item, skipping if it is blank.
If Cells(StaffNumber, 1) <> " " Then
'getting match index number for the value of the cell
match_StaffNumber = WorksheetFunction.Match(Cells(StaffNumber, 1), Range("A1:A" & last_StaffNumber), 0)
If Cells(CallType, 2) <> " " Then
match_CallType = WorksheetFunction.Match(Cells(CallType, 2), Range("B1:B" & last_CallType), 0)
'if the match index is not equals to current row number, then it is a duplicate value
If StaffNumber <> match_StaffNumber And CallType <> match_CallType Then
'Printing the label in the column C
Cells(StaffNumber, 3) = "Duplicate"
End If
End If
End If
Next
Next
End Sub
My problem is that only when Col 1 is a duplicate will the macro enter "Duplicate" into Col C, and it is not checking if the value of Col B is also the same.
Any Help would be much appreciated.
Try this code:
.
Option Explicit
Public Sub showDuplicateRows()
Const SHEET_NAME As String = "Sheet1"
Const LAST_COL As Long = 3 ' <<<<<<<<<<<<<<<<<< Update last column
Const FIRST_ROW As Long = 2
Const FIRST_COL As Long = 1
Const DUPE As String = "Duplicate"
Const CASE_SENSITIVE As Byte = 1 'Matches UPPER & lower
Dim includedColumns As Object
Set includedColumns = CreateObject("Scripting.Dictionary")
With includedColumns
.Add 1, "" ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 1 as dupe criteria
.Add 3, "" ' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< col 3 as dupe criteria
End With
Dim searchRng As Range
Dim memArr As Variant
Dim i As Long
Dim j As Long
Dim unique As String
Dim totalRows As Long
Dim totalCols As Long
Dim totalURCols As Long
Dim valDict As Object
Set valDict = CreateObject("Scripting.Dictionary")
If CASE_SENSITIVE = 1 Then
valDict.CompareMode = vbBinaryCompare
Else
valDict.CompareMode = vbTextCompare
End If
With ThisWorkbook.Sheets(SHEET_NAME)
totalRows = .UsedRange.Rows.Count 'get last used row on sheet
totalURCols = .UsedRange.Columns.Count 'get last used col on sheet
Set searchRng = .Range( _
.Cells(FIRST_ROW, FIRST_COL), _
.Cells(totalRows, LAST_COL) _
)
If LAST_COL < totalURCols Then
.Range( _
.Cells(FIRST_ROW, LAST_COL + 1), _
.Cells(FIRST_ROW, totalURCols) _
).EntireColumn.Delete 'delete any extra columns
End If
End With
memArr = searchRng.Resize(totalRows, LAST_COL + 1) 'entire range with data to mem
For i = 1 To totalRows 'each row, without the header
For j = 1 To LAST_COL 'each col
If includedColumns.exists(j) Then
unique = unique & searchRng(i, j) 'concatenate values on same row
End If
Next
If valDict.exists(unique) Then 'check if entire row exists
memArr(i, LAST_COL + 1) = DUPE 'if it does, flag it in last col
Else
valDict.Add Key:=unique, Item:=i 'else add it to the dictionary
End If
unique = vbNullString
Next
searchRng.Resize(totalRows, LAST_COL + 1) = memArr 'entire memory back to the sheet
End Sub
.
Result:

Resources