Compare 2 Sheets - Use instr(sKeyList) instead of Double Loop (iLoop,R2)
New: Get ALL Matches, not just [First]/[Last]
Sub BasicTemplate_MatchKeys_CopyALLmatches_SingleColumnCopy()
'*************************************************************
'Matches two sheets
'Prompts user for Key on both + column to Copy
'Creates (STRING) [2 part key] on 'larger' list (Key|Row)
'Gets EVERY Matching Occurance, NOT JUST the First/Last
'ONLY copies 1 column worth of data!!!
'*************************************************************
Dim Ws1 As Long, iRe1 As Long, iCe1 As Long, iLoop As Long, aData() As Variant, iColReview As Long, iColCopy As Long, iDumpColCount As Long
Dim Ws2 As Long, iRe2 As Long, iCe2 As Long, aData2() As Variant, aDump() As Variant, iColDump As Long
Dim iColMatchKeyDump As Long, iPos As Long, iStartPos As Long, iEstIndex As Long, sLeft As String, sTwin As String, iRow As Long, sTwinL As Long, sTwinR As Long
Dim sKey2Part As String, aSplitMe As Variant, aSplitTwins As Variant, sCellVal As String, bSplit As Boolean
Erase aData: Erase aDump: Erase aData2
bSplit = False
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws1 = Worksheets("CopyFrom").Index
iRe1 = Range(GetLastCell(Ws1)).Row
iCe1 = Range(GetLastCell(Ws1)).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws2 = Worksheets("PasteTo").Index
iRe2 = Range(GetLastCell(Ws2)).Row
iCe2 = Range(GetLastCell(Ws2)).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Worksheets(Ws1).Select
iColReview = Application.InputBox(Prompt:="What[Column] contains the [Key]? (Data will be COPIED FROM this sheet)", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
iColCopy = Application.InputBox(Prompt:="What[Column] contains the [Field to Copy]?", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
'===================================================================================================
'===================================================================================================
Worksheets(Ws2).Select
iColMatchKeyDump = Application.InputBox(Prompt:="What[Column] contains the [Key]? (Data will be PASTED on this sheet)", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
'===================================================================================================
iDumpColCount = 1
iColDump = iCe2 + 1
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Test Headers to ensure they were found:
If iColReview = 0 Or iColCopy = 0 Or iColDump = 0 Then GoTo gHeaderIssueAbandonAllHope
If iColMatchKeyDump = 0 Then GoTo gHeaderIssueAbandonAllHope
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Worksheets(Ws1).Select
aData = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
'===================================================================================================
Worksheets(Ws2).Select
aDump = Range(Worksheets(Ws2).Cells(1, iCe2 + 1).Address, Worksheets(Ws2).Cells(iRe2, iCe2 + iDumpColCount).Address)
aData2 = Range(Worksheets(Ws2).Cells(1, 1).Address, Worksheets(Ws2).Cells(iRe2, iCe2).Address)
'===================================================================================================
gCreate2PartKey:
'===================================================================================================
'Prepare the string: This String can utilize a 2 part split: Parent = "^"..."^" sandwich // Twins = "^"..."|"..."^"
sKey2Part = "^"
'===================================================================================================
For iLoop = LBound(aData) + 1 To UBound(aData)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = "Getting a list of all non-blank values from [" & Worksheets(Ws1).Name & "] Row: " & iLoop & " of " & UBound(aData)
'Skip [blanks]
If aData(iLoop, iColReview) = "" Then GoTo gMoveToNextLoop
'Add new value to the existing string: [Key][|][Row][^]
sKey2Part = sKey2Part & aData(iLoop, iColReview) & "|" & iLoop & "^"
gMoveToNextLoop:
Next iLoop
aSplitMe = Split(sKey2Part, "^")
bSplit = True
'===================================================================================================
gMatchData:
'===================================================================================================
Application.StatusBar = "Matching the two spreadsheets"
For iLoop = LBound(aData2) + 1 To UBound(aData2)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = "Matching the two spreadsheets - Row: " & iLoop & " of " & UBound(aData2)
'DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD
'Reset the start position on each new Row
iStartPos = 1
'Create a temp string for THIS cells value
sCellVal = aData2(iLoop, iColMatchKeyDump)
'DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
gTestForMatch: ''\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
iPos = InStr(iStartPos, sKey2Part, "^" & sCellVal & "|", vbTextCompare)
If iPos > 0 Then GoTo gFirstMatchFound
GoTo gNoMatchFound
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'////////////////////////////////////////////////////
gFirstMatchFound: ''/////////////////////////////////
'Create a temp string (Left portion of KeyList)
sLeft = Left(sKey2Part, iPos)
'Create an index for the 2nd Split using Replace(Delimiter)
iEstIndex = Len(sLeft) - Len(Replace(sLeft, "^", "", , , vbTextCompare))
'Prevent Debug.Error - if no result, stop this extraction process and move to next row
If iEstIndex = 0 Then GoTo gNoMatchFound
''*********************************************************************
'g11LineMethodToExtractAndAdd: '*
''Assumes ONLY valid data, proceed to accessing the desired chunk '*
' sTwin = aSplitMe(iEstIndex) '*
' '*
''Get the left/right values for this chunk '*
' sTwin = aSplitMe(iEstIndex) '*
' sTwinL = Split(sTwin, "|")(0) '*
' sTwinR = Split(sTwin, "|")(1) '*
' iRow = sTwinR * 1 '*
' '*
''Add the result to aDump '*
' aDump(iLoop, 1) = aDump(iLoop, 1) & aData(iRow, iColCopy) & "^" '*
'''*********************************************************************
gSingleLineMethodToExtractAndAdd:
'Add the result to aDump (Single line method - can replace the 11 lines (5) that it took to accomplish the same thing
aDump(iLoop, 1) = aDump(iLoop, 1) & aData(Split(aSplitMe(iEstIndex), "|")(1) * 1, iColCopy) & "^"
'*********************************************************************
'Check for the next match (if any)
GoTo gCheckForMoreMatches
'////////////////////////////////////////////////////
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
gCheckForMoreMatches: ''\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'Increment the starting position for the test and try again (multiple matches)
iStartPos = iPos + 1
GoTo gTestForMatch
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'////////////////////////////////////////////////////
gNoMatchFound: ''////////////////////////////////////
GoTo gMoveToNextMatchLoop
'////////////////////////////////////////////////////
gMoveToNextMatchLoop:
Next iLoop
'===================================================================================================
gDumpResults:
'===================================================================================================
'Update header for Dump column (x1)
aDump(1, 1) = "Matches: " & aData(1, iColCopy)
'Dump Results:
Worksheets(Ws2).Select
Set Destination = Range(Worksheets(Ws2).Cells(1, iColDump).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'===================================================================================================
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
GoTo gReleaseMemory
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gHeaderIssueAbandonAllHope:
MsgBox "Required Column not set - nothing happened"
GoTo gReleaseMemory
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gReleaseMemory:
Erase aData: Erase aDump: Erase aData2
If bSplit = True Then Erase aSplitMe
Application.ScreenUpdating = True
Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
End Sub
'*************************************************************
'Matches two sheets
'Prompts user for Key on both + column to Copy
'Creates (STRING) [2 part key] on 'larger' list (Key|Row)
'Gets EVERY Matching Occurance, NOT JUST the First/Last
'ONLY copies 1 column worth of data!!!
'*************************************************************
Dim Ws1 As Long, iRe1 As Long, iCe1 As Long, iLoop As Long, aData() As Variant, iColReview As Long, iColCopy As Long, iDumpColCount As Long
Dim Ws2 As Long, iRe2 As Long, iCe2 As Long, aData2() As Variant, aDump() As Variant, iColDump As Long
Dim iColMatchKeyDump As Long, iPos As Long, iStartPos As Long, iEstIndex As Long, sLeft As String, sTwin As String, iRow As Long, sTwinL As Long, sTwinR As Long
Dim sKey2Part As String, aSplitMe As Variant, aSplitTwins As Variant, sCellVal As String, bSplit As Boolean
Erase aData: Erase aDump: Erase aData2
bSplit = False
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws1 = Worksheets("CopyFrom").Index
iRe1 = Range(GetLastCell(Ws1)).Row
iCe1 = Range(GetLastCell(Ws1)).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws2 = Worksheets("PasteTo").Index
iRe2 = Range(GetLastCell(Ws2)).Row
iCe2 = Range(GetLastCell(Ws2)).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Worksheets(Ws1).Select
iColReview = Application.InputBox(Prompt:="What[Column] contains the [Key]? (Data will be COPIED FROM this sheet)", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
iColCopy = Application.InputBox(Prompt:="What[Column] contains the [Field to Copy]?", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
'===================================================================================================
'===================================================================================================
Worksheets(Ws2).Select
iColMatchKeyDump = Application.InputBox(Prompt:="What[Column] contains the [Key]? (Data will be PASTED on this sheet)", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
'===================================================================================================
iDumpColCount = 1
iColDump = iCe2 + 1
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Test Headers to ensure they were found:
If iColReview = 0 Or iColCopy = 0 Or iColDump = 0 Then GoTo gHeaderIssueAbandonAllHope
If iColMatchKeyDump = 0 Then GoTo gHeaderIssueAbandonAllHope
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Worksheets(Ws1).Select
aData = Range(Worksheets(Ws1).Cells(1, 1).Address, Worksheets(Ws1).Cells(iRe1, iCe1).Address)
'===================================================================================================
Worksheets(Ws2).Select
aDump = Range(Worksheets(Ws2).Cells(1, iCe2 + 1).Address, Worksheets(Ws2).Cells(iRe2, iCe2 + iDumpColCount).Address)
aData2 = Range(Worksheets(Ws2).Cells(1, 1).Address, Worksheets(Ws2).Cells(iRe2, iCe2).Address)
'===================================================================================================
gCreate2PartKey:
'===================================================================================================
'Prepare the string: This String can utilize a 2 part split: Parent = "^"..."^" sandwich // Twins = "^"..."|"..."^"
sKey2Part = "^"
'===================================================================================================
For iLoop = LBound(aData) + 1 To UBound(aData)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = "Getting a list of all non-blank values from [" & Worksheets(Ws1).Name & "] Row: " & iLoop & " of " & UBound(aData)
'Skip [blanks]
If aData(iLoop, iColReview) = "" Then GoTo gMoveToNextLoop
'Add new value to the existing string: [Key][|][Row][^]
sKey2Part = sKey2Part & aData(iLoop, iColReview) & "|" & iLoop & "^"
gMoveToNextLoop:
Next iLoop
aSplitMe = Split(sKey2Part, "^")
bSplit = True
'===================================================================================================
gMatchData:
'===================================================================================================
Application.StatusBar = "Matching the two spreadsheets"
For iLoop = LBound(aData2) + 1 To UBound(aData2)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = "Matching the two spreadsheets - Row: " & iLoop & " of " & UBound(aData2)
'DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD
'Reset the start position on each new Row
iStartPos = 1
'Create a temp string for THIS cells value
sCellVal = aData2(iLoop, iColMatchKeyDump)
'DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
gTestForMatch: ''\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
iPos = InStr(iStartPos, sKey2Part, "^" & sCellVal & "|", vbTextCompare)
If iPos > 0 Then GoTo gFirstMatchFound
GoTo gNoMatchFound
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'////////////////////////////////////////////////////
gFirstMatchFound: ''/////////////////////////////////
'Create a temp string (Left portion of KeyList)
sLeft = Left(sKey2Part, iPos)
'Create an index for the 2nd Split using Replace(Delimiter)
iEstIndex = Len(sLeft) - Len(Replace(sLeft, "^", "", , , vbTextCompare))
'Prevent Debug.Error - if no result, stop this extraction process and move to next row
If iEstIndex = 0 Then GoTo gNoMatchFound
''*********************************************************************
'g11LineMethodToExtractAndAdd: '*
''Assumes ONLY valid data, proceed to accessing the desired chunk '*
' sTwin = aSplitMe(iEstIndex) '*
' '*
''Get the left/right values for this chunk '*
' sTwin = aSplitMe(iEstIndex) '*
' sTwinL = Split(sTwin, "|")(0) '*
' sTwinR = Split(sTwin, "|")(1) '*
' iRow = sTwinR * 1 '*
' '*
''Add the result to aDump '*
' aDump(iLoop, 1) = aDump(iLoop, 1) & aData(iRow, iColCopy) & "^" '*
'''*********************************************************************
gSingleLineMethodToExtractAndAdd:
'Add the result to aDump (Single line method - can replace the 11 lines (5) that it took to accomplish the same thing
aDump(iLoop, 1) = aDump(iLoop, 1) & aData(Split(aSplitMe(iEstIndex), "|")(1) * 1, iColCopy) & "^"
'*********************************************************************
'Check for the next match (if any)
GoTo gCheckForMoreMatches
'////////////////////////////////////////////////////
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
gCheckForMoreMatches: ''\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'Increment the starting position for the test and try again (multiple matches)
iStartPos = iPos + 1
GoTo gTestForMatch
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'////////////////////////////////////////////////////
gNoMatchFound: ''////////////////////////////////////
GoTo gMoveToNextMatchLoop
'////////////////////////////////////////////////////
gMoveToNextMatchLoop:
Next iLoop
'===================================================================================================
gDumpResults:
'===================================================================================================
'Update header for Dump column (x1)
aDump(1, 1) = "Matches: " & aData(1, iColCopy)
'Dump Results:
Worksheets(Ws2).Select
Set Destination = Range(Worksheets(Ws2).Cells(1, iColDump).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'===================================================================================================
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
GoTo gReleaseMemory
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gHeaderIssueAbandonAllHope:
MsgBox "Required Column not set - nothing happened"
GoTo gReleaseMemory
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gReleaseMemory:
Erase aData: Erase aDump: Erase aData2
If bSplit = True Then Erase aSplitMe
Application.ScreenUpdating = True
Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
End Sub