I am trying to find an automated solution for the following daily task. I have a master workbook with 13 sheets.
Sheet 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 have tried the following vba codes:
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
and also the following one, which works perfectly:
Code:
Sub TestNewCode()
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
I'm trying to improving the workbook and add some modification to above vba as following:
1- In my monthly sheets now I have 2 sets of columns as you can see in
picture.
As you can see in first set of columns I have 8 titles A-H (REPORT # | DATE | TRANSACTION ID | ITEM CODE | YEAR | PRICE | NOTES | SOLD BY), and in second set I have 4 titles J-M (REPORT # | ITEM CODE | YEAR | PRICE).
2- In DATA sheet I have 1 set of columns with 4 titles A-D (REPORT # | ITEM CODE | YEAR | PRICE). See picture
here.
Improvements I'm looking to make:
1- If finds matches in month tabs (cells A:H) for cells B:C in "DATA" sheet, move (cut) cells A:D from "DATA" to matching month's cells J:M and highlight it yellow.
2- If finds 2 or more matches, first try to move it to the first match, but in case if the first one already has a matching data, move it to the second one.
3- If finds only one match and already there is a data in cells J:M, insert a row below, add data and highlight it blue.
4- If no match finds, highlight cells red in "DATA" tab.
Hope someone can help with this improvement.
Edit mod :cross posted here