Question

UPDATE: I have 2 worksheets: base and référence. référence is constant and have 520 rows. I should compare it to the base that can have 2000 rows. I should match every row from my reference to the base. To be able to have for e.g. for row 1, from the base, added next to it (next to the last cell from row 1) the matched row from référence, and if no matching I will have a blank.

So, I am trying to write a code that should find for each value of a column if this value exists on another column of another worksheet: the réference. If yes Copy entirerow of the reference and paste it next to the matched cell from the 1st worksheet : base.

I have 1600 rows in base to match with the reference table 520 rows, I have a common column for both tables that I can use as a key.

I have tried different methods, none had worked: the problem is that it doesn't paste next to the cells but delete all the rows and replace them by the reference! so I can't know the one that is matched exactly. Or I have an error message : select a cell to paste!

This is my code:

Sub CopyPaste2()

Dim y, lastrow, c, firstAddress, i

Set y = Workbooks.Open("Z:\Base_de_données\Base_Para.xlsx")
lastrow = y.Sheets("Réf").Range("G" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
    With y.Worksheets("base").Cells(i, 7)
        Set c = .Find(y.Worksheets("Réf").Range("B" & i).Value, LookIn:=xlValues) 'this identifies the values in worksheet called R?f
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                'c.Entirerow.Copy
                c.y.Sheets("Réf").Range("A" & i & ":D" & i).Copy
                y.Worksheets("base").Range("A" & i).End(xlUp).Offset(1).PasteSpecial _
                    Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
Next i

End Sub

Thank you a lot for your help! I added a sample of what should i obtain as a result Sample

Answer 1

创建一个值数组以查找并使用.AutoFilter一次性收集它们。

Option Explicit

Sub CopyPaste2()
    Dim vals As Variant, y As Workbook

    Set y = Workbooks.Open("Z:\Base_de_données\Base_Para.xlsx")

    With y.Worksheets("Réf")
        vals = Application.Transpose(.Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value)
    End With

    With y.Worksheets("base")
        If .AutoFilterMode Then .AutoFilterMode = False
        With .Columns("G").Cells
            .AutoFilter field:=1, Criteria1:=vals, Operator:=xlFilterValues
            'check if there is anything to copy
            With .Resize(.Rows.Count - 1, 4).Offset(1, -6)
                If CBool(Application.Subtotal(103, .Cells)) Then
                    .Copy Destination:=.Parent.Worksheets("base").Range("A" & .rows.count).End(xlUp).Offset(1, 0)
                End If
            End With
        End With
        If .AutoFilterMode Then .AutoFilterMode = False
    End With

End Sub

Check if a value exists, if yes copy intire row to another sheet-VBA

1 个答案: