Macro/VBA find match but copy/paste to the wrong place
Closed
avayamj
Posts1Registration dateThursday March 13, 2014StatusMemberLast seenMarch 13, 2014
-
Mar 13, 2014 at 02:19 AM
I found the VBA below to find the matches, unfortunately, it copied to the wrong place. Instead I need those matched codes, copy its corresponding value to column D from "Data" worksheet to the "Master" worksheet. For example, in "Data" worksheet the Code ABC is 3534, it should then copy only the value to the "Master" worksheet's D column. Please help.
Master worksheet
A B C D E
Code Orange Apple Total
ABC 123.00 567.00 690.00
DEF 57,974.34 - 57,974.34
GHI 58,490.00 8.00 58,498.00
MNO 4.00 571.00 575.00
LOK 7,604.00 899.00 8,503.00
MKO - - -
MIL 1,674.00 - 1,674.00
FRE 13,415.12 - 13,415.12
Data worksheet
Code Total
ABC3534 DEF 12276
GHI 3248
IN0019 11726
IN0020 1984
LOK 55
MIL 1472
MNO 10384
Grand Total 121047
Option Explicit
Private Const MASTER_B_COL_IDX As Integer = 2
Private Const DATA_A_COL_IDX As Integer = 1
Public Sub FindMatchingData()
Dim MasterWrkSh As Worksheet
Dim MasterColCount As Integer
Dim MasterRowCount As Long
Dim MasterCol As Integer
Dim MasterRow As Long
Dim DataWrkSh As Worksheet
Dim DataColCount As Integer
Dim DataRowCount As Long
Dim DataRow As Long
Dim CopyData As Integer
Dim PrintData As Integer
Dim Data() As Variant
Set MasterWrkSh = Sheets("Master")
Set DataWrkSh = Sheets("Data")
Application.StatusBar = Format(MasterRow / MasterRowCount, "0 %")
DoEvents
For DataRow = 1 To DataRowCount
If MasterWrkSh.Cells(MasterRow, MASTER_B_COL_IDX) = _
DataWrkSh.Cells(DataRow, DATA_A_COL_IDX) Then
ReDim Preserve Data(DataColCount, UBound(Data, 2) + 1)
Data(0, UBound(Data, 2)) = MasterRow
For CopyData = 1 To DataColCount
Data(CopyData, UBound(Data, 2)) = DataWrkSh.Cells(DataRow, CopyData)
Next
Exit For
End If
Next
Next
For PrintData = 1 To UBound(Data, 2)
For MasterCol = 1 To UBound(Data, 1)
MasterWrkSh.Cells(Data(0, PrintData), MasterCol + MasterColCount) = Data(MasterCol, PrintData)
Next
Next
Set DataWrkSh = Nothing
Set MasterWrkSh = Nothing
End Sub
Related:
Macro/VBA find match but copy/paste to the wrong place