Help for VBA improvement

[Kevin Ten]

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:

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:

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:

(https://ibb.co/irSazQ)
As you can see in first set of columns I have 8 titles (REPORT # | DATE | TRANSACTION ID | ITEM CODE | YEAR | PRICE | NOTES | SOLD BY), and in second set I have 3

titles (REPORT # | ITEM CODE | PRICE).
2- In DATA sheet I have 1 set of columns with 4 titles (REPORT # | ITEM CODE | YEAR | PRICE)

(https://ibb.co/eHKutk)

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.

 

[Peter_SSs]

Welcome to the MrExcel board!

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules. Be sure to follow & read the link at the end of the rule too!

Cross posted at: http://www.msofficeforums.com/excel-programming/36840-help-vba-improvement.html

If you do cross-post in the future and also provide a link, then there shouldn’t be a problem.

 

[Kevin Ten]

Thank you Peter for the edit. My apologies. Also see other links for my cross post here and here.