VBA - Match two values from Table1 to two in Table2 and move/align

[Welshy1491]

Hi there, first time post here so i apologize in advance.

I have looked everywhere for VBA code to help me with this task but can't seem to find what i need.

I have a large table of engineers stock count which i add to once a month when we run our stock reports, the table grows by two columns every month and usually by a number of rows depending on stock intake. Columns A, B & C are Engineers Name, Part No. and Description. The values i add to the table every month are two columns wide which consists of Value and Quantity, so D,E are first months Value and Quantity, F,G are second months Value and Quantity and so on.

My process at the minute is to paste 5 columns of data (Engineers Name, Part No., Description, Value and Quantity) from this months stock report in to the next available columns of my worksheet. I then manually align the 5 columns of copied in data by matching the Engineers Name and Part No. to columns A and B of my original table. If an engineer has added parts to his stock not listed in the table i must create a new line and add the new Part No. in to my table and if he has used stock and no longer has it on the report i have to add zero's in. This can be very time consuming (having to do it for 15 engineers at the moments) and mistakes can be made when manually moving the rows of data to line up with the original data.

I am looking for VBA code which will allow me to automate this if possible? I have added a few pictures hopefully explain the issue clearer. "Initial Tables 1 & 2" show the two tables i begin with, "Intermediate1 & 2" shows the steps i take to align the data and "Final1 & 2" shows my eventual layout of the table.

Any help at all would be greatly appreciated

 

[rpaulson]

I have uploaded you a new file. Make sure your excel is setup to allow macro to run.
Enjoy
-Ross

 

[Fluff]

@rpaulson please post the code to the site as per rule#4
Thanks

 

[rpaulson]

Sorry Fluff, code below

Sub FindNameRow()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim engineer As String, material As String
    Dim lastRow As Long
    Dim i As Long
    Dim matchRow As Long

  
    ' Set worksheets
    Set ws1 = ThisWorkbook.Sheets("Master Table") ' Adjust name if needed
    Set ws2 = ThisWorkbook.Sheets("Dump Data") ' Adjust name if needed
   
    lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column + 1

    'MsgBox lc
   
    For r = 1 To ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
   
    ' Get the first name and last name from Sheet2
    engineer = ws2.Cells(r, "A").Value
    material = ws2.Cells(r, "B").Value
   
    If engineer = "" And material = "" And r > 1 Then GoTo 999 'blank records
   
    ' Find the last row in Sheet1 Column A (assumes contiguous data)
    lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
   
    ' Loop through Sheet1 to find the matching row
    matchRow = 0 ' Default value if no match is found
    For i = 1 To lastRow ' Assuming data starts from row 1
        If ws1.Cells(i, "A").Value = engineer And ws1.Cells(i, "B").Value = material Then
            matchRow = i
            Exit For
        End If
    Next i
   
    ' Display the result
    If matchRow > 0 Then
        'MsgBox "Match found at row: " & matchRow, vbInformation
       
        ws1.Cells(matchRow, lc) = ws2.Cells(r, "D")
        ws1.Cells(matchRow, lc + 1) = ws2.Cells(r, "E")
       
        'ws2.Cells(r, "F") = matchRow
          
    Else
        MsgBox "No match found for " & engineer & " -  " & material, vbExclamation
    End If
   
   
999    Next r


'''write zero for blank entries
 For i = 1 To lastRow ' Assuming data starts from row 2
    If ws1.Cells(i, lc) = "" Then ws1.Cells(i, lc) = 0
    If ws1.Cells(i, lc + 1) = "" Then ws1.Cells(i, lc + 1) = 0
 Next i


ws1.Activate


'copy formats from previos 2 columns
    ws1.Range(ws1.Cells(1, lc - 2), ws1.Cells(lastRow, lc - 1)).Copy
    ws1.Cells(1, lc).PasteSpecial Paste:=xlPasteFormats
   ' ws1.Cells(1, lc + 1).PasteSpecial Paste:=xlPasteFormats

    ' Clear clipboard to remove the marching ants
    Application.CutCopyMode = False


End Sub