Copy Row using Array Matching:
Sub CopyRow_AfterArrayKeyMatch()
Dim Ws1 As Long, iRe1 As Long, iCe1 As Long, iLoop As Long, aData() As Variant, iKey1 As Long, iDumpColCount As Long
Dim Ws2 As Long, iRe2 As Long, iCe2 As Long, aDump() As Variant, iKey2 As Long, iColDump As Long
Dim sKeyList As String, iInstrMatch As Long, sLeft As String, R2 As Long, aKeySource() As Variant, aCount() As Variant
'**********************************************************************
'**********************************************************************
'Note: Ws1 should be the SHORTER list, Ws2 should be the LONGER list
'******************************************************************
'*** Change the Sheet Names in code to match tab Names in Book ***
'******************************************************************
'**********************************************************************
'**********************************************************************
Erase aData: Erase aDump: Erase aKeySource: Erase aCount
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws1 = Worksheets("Short List").Index
iRe1 = Range(GetLastCell(Ws1)).Row
iCe1 = Range(GetLastCell(Ws1)).Column
sKeyList = "^"
Worksheets(Ws1).Select
iKey1 = Application.InputBox(Prompt:="What [Column] contains the KEY to match (NOTE: data will be copied TO this sheet)", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws2 = Worksheets("Magento").Index
iRe2 = Range(GetLastCell(Ws2)).Row
iCe2 = Range(GetLastCell(Ws2)).Column
Worksheets(Ws2).Select
iKey2 = Application.InputBox(Prompt:="What [Column] contains the KEY to match (NOTE: data will be copied FROM this sheet)", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Set the dump parameters (column + # of columns)
iDumpColCount = iCe2
iColDump = iCe1 + 1
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Test Headers to ensure they were found:
If iKey1 = 0 Or iKey2 = 0 Or iColDump = 0 Then GoTo gHeaderIssueAbandonAllHope
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Worksheets(Ws1).Select
aKeySource = Range(Worksheets(Ws1).Cells(1, iKey1).Address, Worksheets(Ws1).Cells(iRe1, iKey1).Address)
'Optional(1 of 3): Count of times a match was made on Source sheet
'aCount = Range(Worksheets(Ws1).Cells(1, iColDump).Address, Worksheets(Ws1).Cells(iRe1, iColDump).Address)
'===================================================================================================
Worksheets(Ws2).Select
aData = Range(Worksheets(Ws2).Cells(1, iKey2).Address, Worksheets(Ws2).Cells(iRe2, iKey2).Address)
'===================================================================================================
'===================================================================================================
For iLoop = LBound(aKeySource) + 1 To UBound(aKeySource)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = iLoop & " of " & UBound(aKeySource)
sKeyList = sKeyList & aKeySource(iLoop, 1) & "^"
Next iLoop
'===================================================================================================
Application.ScreenUpdating = False
'===================================================================================================
For iLoop = LBound(aData) + 1 To UBound(aData)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = iLoop & " of " & UBound(aData)
'Set the Integer that determines if Match was made:
iInstrMatch = InStr(1, sKeyList, "^" & aData(iLoop, 1) & "^", vbTextCompare)
'************************************************************
'Skip this row if NO match:
If iInstrMatch = 0 Then GoTo gMoveToNextRowReview
'************************************************************
'Continue if match:
GoTo gMatchFoundProcessData
'************************************************************
gMatchFoundProcessData:
'Shorten the string
sLeft = Left(sKeyList, iInstrMatch + 1)
'Set the row by determining how many delimiters are in the shortened string (compensating for row by adding 1 - is there a better way?)
R2 = Len(sLeft) - Len(Replace(sLeft, "^", "", , , vbTextCompare)) + 1
''()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
''Alternate Method:
'Dim aSplitMe As Variant
'aSplitMe = Split(sKeyList, "^", , vbTextCompare)
'iSomeVar = aSplitMe(R2)
''()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
'-----------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------
'Copy data to temp array
Worksheets(Ws2).Select
aDump = Range(Worksheets(Ws2).Cells(iLoop, 1).Address, Worksheets(Ws2).Cells(iLoop, iCe2).Address)
'Paste (Dump) the data
Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(R2, iColDump).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'Optional(2 of 3): Count of times a match was made on Source sheet
'aCount(R2, 1) = aCount(R2, 1) + 1
'Clean up the memory
Erase aDump
'-----------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------
gMoveToNextRowReview:
Next iLoop
'===================================================================================================
'===================================================================================================
'Update header
'Copy data to the array:
Worksheets(Ws2).Select
aDump = Range(Worksheets(Ws2).Cells(1, 1).Address, Worksheets(Ws2).Cells(1, iCe2).Address)
'Dump Results:
Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(1, iColDump).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'Optional(3 of 3): Count of times a match was made on Source sheet
'iCe1 = Range(GetLastCell(Ws1)).Column + 1
'Set Destination = Range(Worksheets(Ws1).Cells(1, iCe1).Address)
'Destination.Resize(UBound(aCount, 1), UBound(aCount, 2)).Value = aCount
'===================================================================================================
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
GoTo gReleaseMemory
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gHeaderIssueAbandonAllHope:
MsgBox "Required Column not set - nothing happened"
GoTo gReleaseMemory
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gReleaseMemory:
Erase aData: Erase aDump: Erase aKeySource: Erase aCount
Application.ScreenUpdating = True
Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
MsgBox ("Don't forget to compare the [Key] values on the updated sheet to make sure they match." & Chr(13) & Chr(13) & "If ALL rows match, delete the duplicate Key Column.")
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
End Sub
Dim Ws1 As Long, iRe1 As Long, iCe1 As Long, iLoop As Long, aData() As Variant, iKey1 As Long, iDumpColCount As Long
Dim Ws2 As Long, iRe2 As Long, iCe2 As Long, aDump() As Variant, iKey2 As Long, iColDump As Long
Dim sKeyList As String, iInstrMatch As Long, sLeft As String, R2 As Long, aKeySource() As Variant, aCount() As Variant
'**********************************************************************
'**********************************************************************
'Note: Ws1 should be the SHORTER list, Ws2 should be the LONGER list
'******************************************************************
'*** Change the Sheet Names in code to match tab Names in Book ***
'******************************************************************
'**********************************************************************
'**********************************************************************
Erase aData: Erase aDump: Erase aKeySource: Erase aCount
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws1 = Worksheets("Short List").Index
iRe1 = Range(GetLastCell(Ws1)).Row
iCe1 = Range(GetLastCell(Ws1)).Column
sKeyList = "^"
Worksheets(Ws1).Select
iKey1 = Application.InputBox(Prompt:="What [Column] contains the KEY to match (NOTE: data will be copied TO this sheet)", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
Ws2 = Worksheets("Magento").Index
iRe2 = Range(GetLastCell(Ws2)).Row
iCe2 = Range(GetLastCell(Ws2)).Column
Worksheets(Ws2).Select
iKey2 = Application.InputBox(Prompt:="What [Column] contains the KEY to match (NOTE: data will be copied FROM this sheet)", Title:="Specify Column by Clicking on ANY Cell.", Default:=ActiveCell.Address, Type:=8).Column
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Set the dump parameters (column + # of columns)
iDumpColCount = iCe2
iColDump = iCe1 + 1
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'Test Headers to ensure they were found:
If iKey1 = 0 Or iKey2 = 0 Or iColDump = 0 Then GoTo gHeaderIssueAbandonAllHope
'OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
'===================================================================================================
Worksheets(Ws1).Select
aKeySource = Range(Worksheets(Ws1).Cells(1, iKey1).Address, Worksheets(Ws1).Cells(iRe1, iKey1).Address)
'Optional(1 of 3): Count of times a match was made on Source sheet
'aCount = Range(Worksheets(Ws1).Cells(1, iColDump).Address, Worksheets(Ws1).Cells(iRe1, iColDump).Address)
'===================================================================================================
Worksheets(Ws2).Select
aData = Range(Worksheets(Ws2).Cells(1, iKey2).Address, Worksheets(Ws2).Cells(iRe2, iKey2).Address)
'===================================================================================================
'===================================================================================================
For iLoop = LBound(aKeySource) + 1 To UBound(aKeySource)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = iLoop & " of " & UBound(aKeySource)
sKeyList = sKeyList & aKeySource(iLoop, 1) & "^"
Next iLoop
'===================================================================================================
Application.ScreenUpdating = False
'===================================================================================================
For iLoop = LBound(aData) + 1 To UBound(aData)
DoEvents
If Right(iLoop, 2) = "00" Then Application.StatusBar = iLoop & " of " & UBound(aData)
'Set the Integer that determines if Match was made:
iInstrMatch = InStr(1, sKeyList, "^" & aData(iLoop, 1) & "^", vbTextCompare)
'************************************************************
'Skip this row if NO match:
If iInstrMatch = 0 Then GoTo gMoveToNextRowReview
'************************************************************
'Continue if match:
GoTo gMatchFoundProcessData
'************************************************************
gMatchFoundProcessData:
'Shorten the string
sLeft = Left(sKeyList, iInstrMatch + 1)
'Set the row by determining how many delimiters are in the shortened string (compensating for row by adding 1 - is there a better way?)
R2 = Len(sLeft) - Len(Replace(sLeft, "^", "", , , vbTextCompare)) + 1
''()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
''Alternate Method:
'Dim aSplitMe As Variant
'aSplitMe = Split(sKeyList, "^", , vbTextCompare)
'iSomeVar = aSplitMe(R2)
''()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()
'-----------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------
'Copy data to temp array
Worksheets(Ws2).Select
aDump = Range(Worksheets(Ws2).Cells(iLoop, 1).Address, Worksheets(Ws2).Cells(iLoop, iCe2).Address)
'Paste (Dump) the data
Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(R2, iColDump).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'Optional(2 of 3): Count of times a match was made on Source sheet
'aCount(R2, 1) = aCount(R2, 1) + 1
'Clean up the memory
Erase aDump
'-----------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------
gMoveToNextRowReview:
Next iLoop
'===================================================================================================
'===================================================================================================
'Update header
'Copy data to the array:
Worksheets(Ws2).Select
aDump = Range(Worksheets(Ws2).Cells(1, 1).Address, Worksheets(Ws2).Cells(1, iCe2).Address)
'Dump Results:
Worksheets(Ws1).Select
Set Destination = Range(Worksheets(Ws1).Cells(1, iColDump).Address)
Destination.Resize(UBound(aDump, 1), UBound(aDump, 2)).Value = aDump
'Optional(3 of 3): Count of times a match was made on Source sheet
'iCe1 = Range(GetLastCell(Ws1)).Column + 1
'Set Destination = Range(Worksheets(Ws1).Cells(1, iCe1).Address)
'Destination.Resize(UBound(aCount, 1), UBound(aCount, 2)).Value = aCount
'===================================================================================================
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
GoTo gReleaseMemory
'EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gHeaderIssueAbandonAllHope:
MsgBox "Required Column not set - nothing happened"
GoTo gReleaseMemory
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
gReleaseMemory:
Erase aData: Erase aDump: Erase aKeySource: Erase aCount
Application.ScreenUpdating = True
Application.StatusBar = ""
Application.Calculation = xlCalculationAutomatic
MsgBox ("Don't forget to compare the [Key] values on the updated sheet to make sure they match." & Chr(13) & Chr(13) & "If ALL rows match, delete the duplicate Key Column.")
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
End Sub