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
I have two sheets. One is a database containing all information in rows from columns A to I. In the other sheet, I have the same structure in columns but only info in column A and E which will give a unique combination of only matching one row in database.
So ONLY when the cell in column A and E match a row in the database, I want the full row from the database copied into this row. My vba so far only copies one row/last row...
CodePudding user response:
Update Worksheet Rows
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