![]() |
#1
|
|||
|
|||
![]()
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 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 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 Last edited by Pecoflyer; 09-22-2017 at 11:22 PM. Reason: Changed last sentence with ref to cross post |
Tags |
excel improvement, vba |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
eNGiNe | Forum Support | 1 | 09-14-2016 04:14 PM |
![]() |
raminraiszadeh | Project | 1 | 04-05-2016 06:05 AM |
Form improvement | edayers315 | Word | 0 | 08-19-2011 09:55 AM |