VBA for find, match and move data - vba

Question

I am trying to find an automated solution for the following daily task.
I have a master workbook with 13 sheets.
Names are Jan-Dec (all 12 months) and Data.
Every sheet has 2 sets of 3 columns: Item Code (A1), Year (B1), Price (C1) and Item Code (E1), Year (F1), Price (G1).
Every day I have over 1000 new entries in "Data" sheet and then have to find matching item code (in Column A) in other 12 sheets, columns A-C, cut and move new matching data to E-G and highlight the new entries.
I tried the following vba code:
Sub TestNewCode()
Application.ScreenUpdating = False
Dim varMainRange As Range
Dim varSubRange As Range
Set varMainRange = Range(Worksheets("Jul").Range("A2:C65536"), _
Worksheets("Jul").Range("A65536").End(xlUp))
For Each MainCell In varMainRange
Set varSubRange = Range(Worksheets("Data").Range("A2"), _
Worksheets("Data").Range("A65536").End(xlUp))
For Each SubCell In varSubRange
If MainCell.Value = SubCell.Value Then
Worksheets("Data").Range("A2:C2").Copy _
Worksheets("Jul").Range("E2:G2")
Exit For
End If
Next SubCell
Next MainCell
Application.ScreenUpdating = True
End Sub
As you can see this code can move only one cell.
I'll appreciate if someone can show a solution to this matter.

Answer 1

I didn't fully test this code, in part because I doubt that you really want to post the data to any of the 12 monthly sheets. Instead, I suspect that the data must be posted to one particular of the monthly sheets. However, that isn't what you said, and therefore my code will look in all sheets and stop looking after it finds a match. This is something you may find easy to adjust. Otherwise I can help you do it.
However, what this code needs now is thorough testing. :-)
Sub TestNewCode()
' 16 Sep 2017
Const Tabs As String = "Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"
Dim WsData As Worksheet
Dim Ws As Worksheet ' any of the monthly sheets
Dim WsName() As String
Dim Rend As Long, Rl As Long ' last row in WsData / Ws
Dim R As Long, Rm As Long ' row counter WsData / Ws
Dim Entry As Variant ' one Data entry
Set WsData = Worksheets("Data")
WsName = Split(Tabs, " ")
Application.ScreenUpdating = False
With WsData
Rend = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 2 To Rend
Entry = .Range(.Cells(R, 1), .Cells(R, 3)).Value ' A:C
Rm = FindMatch(Entry, Ws, WsName)
If Rm Then ' rm = 0 if not found
With Ws.Cells(Rm, 5).Resize(1, UBound(Entry, 2))
.Value = Entry
.Interior.Color = vbYellow
End With
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Private Function FindMatch(Entry As Variant, _
Ws As Worksheet, _
WsName() As String) As Long
' return zero if no match was found
Dim Rng As Range ' search range
Dim Fnd As Range
Dim Rl As Long
Dim i As Long
For i = 0 To UBound(WsName)
On Error Resume Next
Set Ws = Worksheets(WsName(i))
If Err Then
MsgBox "Worksheet " & WsName(i) & " doesn 't exist.", _
vbInformation, "Missing worksheet"
Else
With Ws
Rl = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Rng = .Range(.Cells(2, 1), .Cells(Rl, 3))
Set Fnd = Rng.Find(What:=Entry(1, 1), _
After:=Rng.Cells(Rng.Cells.Count), _
LookIn:=xlValues, _
Lookat:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
MatchByte:=False)
If Not Fnd Is Nothing Then
FindMatch = Fnd.Row
Exit For
End If
End With
End If
Next i
If Fnd Is Nothing Then
MsgBox "Code " & Entry(1, 1) & " wasn't found.", _
vbInformation, "Missing Code"
End If
End Function