Match Value and copy onto same line Excel VBA-CodePudding

I hope you’re all well.

I have some VBA code that I’m having a little trouble with & was wondering if anyone might be able to lend a hand, please?

The issue; If there are multiple rows on sheet 1 that need to be copied, I’m only able to copy one line. I can’t figure out how to make it search, match and then copy for multiple lines.

EDIT What I'm hoping to achieve is to copy the values in columns; M, N & O (Date Paid, Amount Paid, Notes) into their respective rows in the table on sheet 2, columns I, J & L (Amount Received, Date Received & Notes)

My VBA skills and somewhat limited ahah and so I never got very far with this.

Updated screenshots of sheet 1 and sheet 2

EDIT

CodePudding user response：

Copy Matching Rows to an Excel Table (ListObject)

Note that a simple formula in D2 (copy to the rest of the cells) of the table could do the same:
```
=IFERROR(INDEX(Sheet1!D:D,MATCH([@Invoice NR],Sheet1!$A:$A,0)),"")
```

Option Explicit

Sub UpdateTable()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
    If slRow < 2 Then Exit Sub ' no data in column range
    Dim srg As Range: Set srg = sws.Range("A2:A" & slRow) ' to lookup
    Dim scrg As Range: Set scrg = srg.EntireRow.Columns("D:G") ' to copy
    Dim cCount As Long: cCount = scrg.Columns.Count ' how many columns in 'D:G'?
    
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
    Dim dtbl As ListObject: Set dtbl = dws.ListObjects("Table1")
    
    Dim srIndex As Variant
    Dim dCell As Range
    
    ' Copy.
    For Each dCell In dtbl.ListColumns(1).DataBodyRange
        srIndex = Application.Match(dCell.Value, srg, 0) ' find a match
        If IsNumeric(srIndex) Then ' if match was found then copy if not blank
            If Application.CountBlank(scrg.Rows(srIndex)) < cCount Then
                dCell.Offset(, 3).Resize(, cCount).Value _
                    = scrg.Rows(srIndex).Value
            End If
        End If
    Next dCell
    
    ' Inform.
    MsgBox "Table updated."

End Sub

CodePudding user response：

    Sub missingData()

Dim s1 As Worksheet
Dim s2 As Worksheet
Set s1 = ActiveWorkbook.Worksheets("Sheet1")
Set s2 = ActiveWorkbook.Worksheets("Sheet2")

lrow = Cells(Rows.Count, 1).End(xlUp).Row   1

Dim i As Integer
i = 1   //start index

Do While (i < lrow)

    For j = 1 To 7
        If s1.Cells(i, j) <> "" And s2.Cells(i, j) = "" Then
            s2.Cells(i, j) = s1.Cells(i, j)


        End If
    Next j
    i = i   1
Loop
End Sub

i think it will solve problem but it can get some time if your file has a big data