SVerweis vs. VBA - Zusammenstellung nach Vergleich über mehrere Spalten in mehreren Sheets

Option Explicit

Private Const SheetUser = "Benutzer"        'Tabellenname Benutzer  
Private Const SheetPC = "PC"                'Tabellenname PC  

Private Const ColOrtUser = 14               'Benutzer-Ort Spalte N  
Private Const ColOrtPC = 2                  'PC-Ort Spalte B  

Private Const ColPastePC = 5                'PC-Paste ab Spalte E  
Private Const RowStartPC = 2                'PC-Ort ab Zeile 2  

Private Const RngCopyUser = "B?,E?,F?,I?,J?,N?,P?"  

Public Sub CopyUserData()
    Dim oWksUser As Worksheet, oCell As Range, oFound As Range
    
    Set oWksUser = Sheets(SheetUser)
    
    With Sheets(SheetPC)
        For Each oCell In .Cells(RowStartPC, ColOrtPC).Resize(.UsedRange.Rows.Count, 1)
            If oCell.Text <> "" Then  
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If oFound Is Nothing Then
                    MsgBox "Ort nicht gefunden: " & oCell.Value, vbInformation, "Ort-Suche..."  
                Else
                   oWksUser.Range(Replace(RngCopyUser, "?", oFound.Row)).Copy .Cells(oCell.Row, ColPastePC)  
                End If
            End If
        Next
    End With
End Sub

Option Explicit

Private Const SheetUser = "Benutzer"        'Tabellenname Benutzer  
Private Const SheetPC = "PC"                'Tabellenname PC  
Private Const SheetNew = "Tabelle1"         'Tabellenname Tabelle1  

Private Const ColOrtUser = 14               'Benutzer-Ort Spalte N  
Private Const ColOrtPC = 2                  'PC-Ort Spalte B  

Private Const ColPastePC = 1                'New-Paste PC ab Spalte A  
Private Const ColPasteUser = 5              'New-Paste User ab Spalte E  

Private Const RowStart = 2                  'PC-Sheet ab Zeile 2  

Private Const RngCopyPC = "A?,B?,C?,F?"  
Private Const RngCopyUser = "B?,E?,F?,I?,J?,N?,P?"  

Public Sub CopyUserData()
    Dim oWksUser As Worksheet, oWksNew As Worksheet, oCell As Range, oFound As Range
    
    Set oWksUser = Sheets(SheetUser)
    Set oWksNew = Sheets(SheetNew)
    
    With Sheets(SheetPC)
        For Each oCell In .Cells(RowStart, ColOrtPC).Resize(.UsedRange.Rows.Count, 1)
            If oCell.Text <> "" Then  
               .Range(Replace(RngCopyPC, "?", oCell.Row)).Copy oWksNew.Cells(oCell.Row, ColPastePC)  
                
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not oFound Is Nothing Then
                    oWksUser.Range(Replace(RngCopyUser, "?", oFound.Row)).Copy oWksNew.Cells(oCell.Row, ColPasteUser)  
                End If
            End If
        Next
    End With
End Sub

RngCopyUser = "B?,E?,F?,M?,I?,J?,X?,N?,P?"  

Private Const SheetNew = "Assoziation"  

Private Const ColPastePC = 1

Private Const RngCopyUser = "B,E,F,M,I,J,X,N,P"  

Private Sub Test()
    Dim oWksNew As Worksheet, aColumns As Variant, iRow As Long, i As Long
    
    Set oWksNew = Sheets(SheetNew)
    
    aColumns = Split(RngCopyUser, ",")  'In einzelne Spalten splitten  
    
    iRow = 20    'Alias Found.Row  
    
    With Sheets(SheetPC).Rows(iRow)
        For i = 0 To UBound(aColumns)  'Spalten einzeln kopieren  
            .Columns(aColumns(i)).Copy oWksNew.Cells(iRow, ColPastePC).Offset(0, i)
        Next
    End With
End Sub

Option Explicit
Option Compare Text

Private Const SheetPC = "PC"                'Tabellenname PC  
Private Const SheetUser = "Benutzer"        'Tabellenname Benutzer  
Private Const SheetMon = "Monitore"         'Tabellenname Monitore  
Private Const SheetNew = "Assoziation"      'Tabellenname Neu  

Private Const ColOrtPC = 2                  'PC-Ort Spalte B  
Private Const ColOrtUser = 14               'Benutzer-Ort Spalte N  
Private Const ColOrtMon = 6                 'Monitore-Ort Spalte F  

Private Const ColPasteUser = 1              'New-Paste User ab Spalte A  
Private Const ColPastePC = 10               'New-Paste PC ab Spalte J  
Private Const ColPasteMon1 = 14             'New-Paste Monitore ab Spalte N  
Private Const ColPasteMon2 = 17             'New-Paste Monitore ab Spalte Q  

Private Const RowStart = 2                  'Daten ab Zeile 2  

Private Const RngCopyPC = "A,B,C,F"  
Private Const RngCopyUser = "B,E,F,M,I,J,X,N,P"  
Private Const RngCopyMon = "B,E,F"  

Public Sub CopyDataNewSheet()
    Dim oWksUser As Worksheet, oWksMon As Worksheet
    Dim oCell As Range, oFound As Range, oNext As Range
    
    Sheets(SheetNew).UsedRange.Offset(1).Clear     'New-Sheet zuvor leeren?  
    
    Set oWksUser = Sheets(SheetUser)
    Set oWksMon = Sheets(SheetMon)
    
    With Sheets(SheetPC)
        For Each oCell In .Cells(RowStart, ColOrtPC).Resize(.UsedRange.Rows.Count, 1)
            If oCell.Text <> "" Then  
                Call CopyData(SheetPC, RngCopyPC, oCell.Row, oCell.Row, ColPastePC)
               
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not oFound Is Nothing Then
                    Call CopyData(SheetUser, RngCopyUser, oFound.Row, oCell.Row, ColPasteUser)
                End If
            
                Set oFound = oWksMon.Columns(ColOrtMon).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not oFound Is Nothing Then
                    Call CopyData(SheetMon, RngCopyMon, oFound.Row, oCell.Row, ColPasteMon1)
                    
                    Set oNext = oWksMon.Columns(ColOrtMon).FindNext(oFound)
                    If oFound.Address <> oNext.Address Then
                        Call CopyData(SheetMon, RngCopyMon, oNext.Row, oCell.Row, ColPasteMon2)
                    End If
                End If
            End If
        Next
    End With
End Sub

Private Sub CopyData(ByRef sSheet, ByRef sArea, ByVal iRowCopy As Long, _
                     ByVal iRowPaste As Long, ByVal iColPaste As Long)
    
    Dim oCellsPaste As Range, aColumns As Variant, i As Long
    
    aColumns = Split(sArea, ",")  
    
    Set oCellsPaste = Sheets(SheetNew).Cells(iRowPaste, iColPaste)
    
    With Sheets(sSheet).Rows(iRowCopy)
        For i = 0 To UBound(aColumns)
            .Columns(aColumns(i)).Copy oCellsPaste.Offset(0, i)
        Next
    End With
End Sub

Private Const ColOrtNew = 11

Sheets(SheetNew).UsedRange.RemoveDuplicates Columns:=ColOrtNew, Header:=xlYes