当两列单元格中的值与另一列中相同列中的值匹配时 sheet，然后复制整行

Question

Option Explicit

Sub test()
 
  Dim rg As Range
  Dim name As String
  Dim name2 As String
  Dim wsh1 As Worksheet, wsh2 As Worksheet
  Dim i As Long

 
  Set wsh1 = ThisWorkbook.Worksheets("Database")
  Set wsh2 = ThisWorkbook.Worksheets("Løbs-skabelon")
  
  On Error GoTo 0

  Application.ScreenUpdating = False
  
  name = wsh2.Range("a" & Rows.Count).End(xlUp).Value
  name2 = wsh2.Range("e" & Rows.Count).End(xlUp).Value

  For i = 1 To wsh1.Range("a" & Rows.Count).End(xlUp).Row
    
  If wsh1.Cells(i, 1) = name And wsh1.Cells(i, 5) = name2 Then

  wsh1.Range(wsh1.Cells(i, 1), wsh1.Cells(i, 9)).Copy
  
 wsh2.Range("a" & Rows.Count).End(xlUp).PasteSpecial xlPasteValues
  Application.CutCopyMode = False
     
 End If

 Next i
 
Application.ScreenUpdating = True

Worksheets("Løbs-skabelon").Range("a3").Select

Exit Sub

End Sub

我有两个 sheet。一个是包含从 A 列到 I 列的所有行中的所有信息的数据库。在另一个 sheet 中，我在列中具有相同的结构，但只有 A 列和 E 列中的信息，这将给出仅匹配一行的唯一组合在数据库中。

因此，只有当 A 列和 E 列中的单元格与数据库中的一行匹配时，我才希望将数据库中的整行复制到这一行中。我的 vba 到目前为止只复制了一个 row/last 行...

worksheet database

Answer 1

更新工作表行

Option Explicit

Sub UpdateWorksheetRows()
 
    Const sName As String = "Database"
    Const sfRow As Long = 5
    
    Const dName As String = "Lobs-skabelon"
    Const dfRow As Long = 5
    
    Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Range("A" & sws.Rows.Count).End(xlUp).Row
    Dim srCount As Long: srCount = slRow - sfRow + 1
    Dim srg1 As Range: Set srg1 = sws.Range("A5").Resize(srCount)
    Dim srg2 As Range: Set srg2 = sws.Range("E5").Resize(srCount)
    
    Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets(dName)
    Dim dlRow As Long: dlRow = dws.Range("A" & dws.Rows.Count).End(xlUp).Row
    Dim drCount As Long: drCount = dlRow - dfRow + 1
    
    Application.ScreenUpdating = False
    
    Dim sIndex As Variant
    Dim r As Long
     
    For r = dfRow To dlRow
        sIndex = dws.Evaluate("MATCH(1,('" & sName & "'!" & srg1.Address & "=" _
            & dws.Range("A" & r).Address & ")*('" & sName & "'!" _
            & srg2.Address & "=" & dws.Range("E" & r).Address & "),0)")
        If IsNumeric(sIndex) Then
            'Debug.Print r, sIndex
            dws.Rows(r).Columns("A:I").Value _
                = srg1.Cells(sIndex).EntireRow.Columns("A:I").Value
        End If
    Next r
    
    Worksheets("Lobs-skabelon").Range("A3").Select

    Application.ScreenUpdating = True
    
    MsgBox "Worksheet rows updated.", vbInformation

End Sub

当两列单元格中的值与另一列中相同列中的值匹配时 sheet，然后复制整行

When values in cells in two columns match values in the same columns in another sheet, then copy the whole row

excel

vba

更新工作表行