Match Value and copy onto same line Excel VBA

Question

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

Does *"If there are multiple rows on sheet 1"* mean that your code is copying only one line? Could you accurately explain what *"skipping the blanks"* means, are you afraid to overwrite some existing data? BTW, `Offset(, 4)` means column `E`, not column `D`. — VBasic2008, Mar 05 '22 at 03:14
Hi @VBasic2008 Thanks for the fast post! Yes that is correct, only copying one line from sheet 1.The easiest way to describe missing the blanks is with an example; What should be copied over to sheet 2 is the completed data; for invoice 1 the Date Paid, Amount Paid, Account & Notes should be copied. Invoice 2 should be skipped as it’s not “completed”. Invoice 3 the Date Paid, Amount Paid, Account & Notes should be copied. Invoice 4 should be skipped as its not “completed” Hope thats made it a little clearer. :) — new11, Mar 05 '22 at 04:44

VBasic2008 · Accepted Answer · 2022-03-05T04:54:41.450

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

Wow thanks @VBasic2008 that works amazing & you are an absolute genius!! I had a go of changing some of the codes copy & searching ranges but my vba skills are not really the greatest, and well the results were interesting haha. I’m just about to update my question, would you mind taking another look please? The ranges on sheet 1 start from rows C19:C24 & columns C:O — new11, Mar 05 '22 at 05:45
After a few more attempts & lots of googling haha, I was able to edit the code for my workbook. I’ve been banging my head against a wall having to input this small amount of data manually. You have done an incredible service with your simple magic piece of code! Thank you. — new11, Mar 06 '22 at 05:17

score 0 · Answer 2 · answered Mar 05 '22 at 02:31

0

    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

answered Mar 05 '22 at 02:31

Serhat Balpetek

11
3

1

Hi @Serhat Balpetek Thanks for the reply and code! Although the code works perfectly for matching & copying data from sheet 1 to sheet 2. I run into some issues when applying it to a production workbook that has the data in different places. (please see sc) Is there a way that I can define the ranges or cells that the code searches on sheet 1? Screen shots https://ibb.co/yhQsZrH https://ibb.co/p1zHB5R – new11 Mar 05 '22 at 05:16
Your answer could be improved with additional supporting information. Please [edit] to add further details, such as citations or documentation, so that others can confirm that your answer is correct. You can find more information on how to write good answers [in the help center](/help/how-to-answer). – Community Mar 05 '22 at 05:38

Match Value and copy onto same line Excel VBA

2 Answers2

Copy Matching Rows to an Excel Table (ListObject)