aivilon
Goto Top

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

Hallo Zusammen

Ich brauche ziemlich dringend eine Auswertung, die ich am besten über einen SVerweis oder VBA mache. Leider habe ich noch nie zuvor SVerweise benötigt und weiss nichts drüber. Leider bin ich auch überhaupt nicht stark in VBA und bin da sehr eingerostet. Mir stellt sich auch die Frage, mit was mein Anliegen einfacher/besser zu erstellen ist: VBA oder SVerweis.

Hier mein Fallbeispiel.

Tabelle Benutzer:
B E F I J N P
ADNAME FNAME VNAME ABT EMAIL ORT TEL1
MaxMu Muster Max IT Max.Muster@Firma.ch Firmensitz-199-01 056 565 56 56
KarlaBe Beispiel Karla IT Karla.Beispiel@Firma.ch Firmensitz-254-02 056 565 57 57
SysAdmin System Admin IT System.Admin@Firma.ch Firmensitz-000-1 056 565 01 01

Tabelle PC
A B C F
SNAME ORT TYP INVNR
PC02001 Firmensitz-199-01 HP 8510 23456
PC02015 Firmensitz-254-02 HP 8560 123457
PC02115 Firmensitz-280-10 HP 8510 123654

So, die Formel oder das Script soll nun Zelle für Zelle in Tabelle PC, Spalte Ort folgendes machen:
Zelle 2 in Spalte Ort in Tabelle PC mit der Spalte Ort in Tabelle Benutzer vergleichen
Bei einem Fund:
die Zeile des Ortes in Tabelle1 kopieren
die Zeile, in der der Ort in Tabelle Benutzer vorkam, auch kopieren und in Tabelle1 hinter die vorhin eingefügte setzen

Bei keinem Fund:
die Zeile des Ortes in Tabelle1 kopieren

Das Resultat sollte also so aussehen (in einer neuen Tabelle Namens "Tabelle1"):
A B C D E F G H I J K
PC02001 Firmensitz-199-01 HP 8510 123456 MaxMu Muster Max IT Max.Muster@Firma.ch Firmensitz-199-01 056 565 56 56
PC02015 Firmensitz-254-02 HP 8560 123457 KarlaBe Beispiel Karla IT Karla.Beispiel@Firma.ch Firmensitz-254-02 056 565 57 57
PC02115 Firmensitz-280-10 HP 8510 123654


Es ist natürlich nicht immer die selbe Reihenfolge....Denn es kann auch sein, dass an einem platz mehrere Geräte sind. In diesem Falle sind dann einfach im Resultat die Zeilen "doppelt" also quasi so:
PC02001 Firmensitz-199-01 HP 8510 123456 MaxMu Muster Max IT Max.Muster@Firma.ch Firmensitz-199-01 056 565 56 56
PC02051 Firmensitz-199-01 HP 8560 123789 MaxMu Muster Max IT Max.Muster@Firma.ch Firmensitz-199-01 056 565 56 56

Wer kann und will mir helfen face-sad


Ich danke im Vorraus!


Grüsse Aivilon

Content-ID: 250664

Url: https://administrator.de/forum/sverweis-vs-vba-zusammenstellung-nach-vergleich-ueber-mehrere-spalten-in-mehreren-sheets-250664.html

Ausgedruckt am: 23.12.2024 um 08:12 Uhr

colinardo
colinardo 01.10.2014, aktualisiert am 02.10.2014 um 19:58:31 Uhr
Goto Top
Hallo Aivilon,
schau es dir anhand dieses Demo-Sheet's ab das auf deinen Daten basiert (Formel-Lösung): demo_verweis_250664.xlsx

In VBA habe ich das hier auch schon ziemlich oft gepostet:

Grüße Uwe
116301
Lösung 116301 01.10.2014, aktualisiert am 02.10.2014 um 11:41:32 Uhr
Goto Top
Hallo Aivilon!

Und per VBA in etwa so:
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
wobei ich mir nicht sicher bin, ob sich der Ort im PC-Sheet in Spalte B befindet. Wenn Nein, die Variablen 'ColOrtPC' und 'ColPastePC' entsprechend anpassenface-wink


Grüße Dieter
aivilon
aivilon 01.10.2014 aktualisiert um 13:50:56 Uhr
Goto Top
Hallo Dieter

Erst mal schon ein Danke!

Zweitens: Ich glaub ich bin nicht nur eingerostet...ich versteh nur noch Bahnhof... face-sad

Hab dein Beispiel so versucht anzupassen, dass ich auch bei nichtfinden die Zellen vom PC in die neue Tabelle kopiere. Des weiteren eben dass eine neue Tabelle verwendet wird und es nicht in der existierenden reinkopiert wird...
und in der neuen soll demnach also die 4 Zellen von der PC Zeile und die 7 der User Zeile hintereinander stehen...aber brings nicht hin... face-sad

Bei deiner Version wird mir nur die Zeile E über die F Zeile im PC geschrieben.

Ich passe oben noch die Zeilenbeschriftungen an...


Grüsse Pascal


Meine Weiterführung des Codes (Achtung ich habe gefailt...):
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                'PC-Paste ab Spalte A  
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, 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(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
                    oWksNew.Range(Replace(RngCopyUser, "?", oFound.Row)).Copy .Cells(oCell.Row, ColPaste)  
                    'MsgBox "Ort nicht gefunden: " & oCell.Value, vbInformation, "Ort-Suche..."  
                Else
                   oWksNew.Range(Replace(RngCopyUser, "?", oFound.Row)).Copy .Cells(oCell.Row, ColPastePC)  
                End If
            End If
        Next
    End With
End Sub
116301
Lösung 116301 01.10.2014, aktualisiert am 02.10.2014 um 11:36:04 Uhr
Goto Top
Hallo Pascal!

In neues Sheet (Tabelle1) dann in etwa so:
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

Grüße Dieter
aivilon
aivilon 02.10.2014 um 11:41:25 Uhr
Goto Top
Du bist super! Funktioniert super! Ich danke dir herzlich für die schnelle Hilfe!!

Ist genau das und macht genau das wo es soll face-smile

Danke Danke Danke!


Gruess, Pascal
116301
116301 02.10.2014 um 12:22:25 Uhr
Goto Top
Hallo Pascal!

Gerne dochface-smile

Und die Email-Benachrichtigungen funktionieren nun auch wieder, nachdem ich beim Provider den Spam-Filter auf niedrig gesetzt habeface-wink

Grüße Dieter
colinardo
colinardo 02.10.2014 aktualisiert um 19:57:22 Uhr
Goto Top
Zitat von @aivilon:
Danke Danke Danke!
ich bedanke mich auch für das kommentarlose Ignorieren face-wink.

Gruß Uwe
aivilon
aivilon 24.10.2014 um 16:59:33 Uhr
Goto Top
Moinsen Dieter

Erneute Runde...
Ich will die Monitore (wiederum ein einzelnes Sheet) hinten ran hängen im neuen Sheet. Die Problematik: es gibt praktisch für alle Benutzer zwei Monitore. Ich hab mir das ganze Script mal angeschaut und weitergeführt. Leider stocke ich ein bisschen bei der Logik und der Umsetzung:

Option Explicit

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

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

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

Private Const RowStart = 2                  'User-Sheet 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?"  
Private Const RngCopyMon2 = "B?,E?,F?"  




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

                Set Monfound = oWksMon.Columns(ColOrtMon).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not Monfound Is Nothing Then
                    If Not oWksMon.Range Is Nothing Then
                        oWksMon.Range(Replace(RngCopyMon, "?", Monfound.Row)).Copy oWksNew.Cells(oCell.Row, ColPasteMon)  
                            Set Mon2Found = oWksMon2.Columns(ColOrtMon2).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                            If Not Mon2Found Is Nothing Then
                                If Not oWksMon2.Range Is Nothing Then
                                    oWksMon2.Range(Replace(RngCopyMon2, "?", Mon2Found.Row)).Copy oWksNew.Cells(oCell.Row, ColPasteMon2)  
                            End If
                End If
                
            End If
        Next
    End With
    
End Sub

Meine Logik ist, einfach unter dem oFound, wo die PCs hinter die Benutzer gehängt werden (Jap ich hab das Script umgemoddelt face-smile ), einfach noch das selbe mit den Monitoren zu machen. Da es aber zwei sind, müsste ich ja dann eine Verschachtelung der beiden Bereiche machen.

Leider läufts nicht face-sad...

Wie mache ich das am besten mit der Range Abfrage der Monitore in den Zeilen N,O, und P? Ich muss ja erst wissen, ob die noch leer sind, damit ich die Zeilen danach hochzählen kann und den zweiten Monitor ab Zeile Q einfügen kann. Also im Endeffekt sollte mein SheetNew dann folgende Zeilen haben:
AD Name User, Fname User, Vname User, Abteilung User, Email User, Funktion User, ORT User, Telefonnummer, Aktiv, Gerätename, ORT Gerät, TYP Gerät, INV Gerät, Mon1 Typ, Mon1 Inv, Mon1 Ort, Mon2 Typ, Mon2 Inv, Mon2 Ort

Aber langsam kommts wieder mit den VBA Kentnissen. Noch nicht so tief aber.... yehy :D


Grüsse, Aiv
aivilon
aivilon 24.10.2014 um 16:59:55 Uhr
Goto Top
Sorry Uwe, aus Euphorie übersehen.
116301
116301 25.10.2014 um 18:10:35 Uhr
Goto Top
Hallo aivilon !

Zunächst wäre erstmal zu klären, ob Du tatsächlich nach diesem Muster kopieren willst:
RngCopyUser = "B?,E?,F?,M?,I?,J?,X?,N?,P?"  

In dem Fall funktioniert die bisherige Kopier-Methode nicht, da die Daten im Ziel-Sheet in alphabetischer Reihenfolge kopiert werden. D.h. die Spalte X landet z.B. im neuen Sheet an letzter Stelle (Spalte I)...

Bei obiger Reihenfolge müssen die Zellen einzeln kopiert werden und das ginge dann in etwa so:
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
Grüße Dieter
116301
Lösung 116301 26.10.2014, aktualisiert am 31.10.2014 um 08:52:00 Uhr
Goto Top
Hallo aivilon !

Wenn ich das richtig verstanden habe, dass im Sheet Monitor die Monitore untereinander stehen d.h. für Ort 1-2 Such-Treffer möglich sind, dann in etwa so:
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
Wobei ich mich schon frage, warum der Ort in einer Zeile gleich mehrfach stehen muss?

Grüße Dieter
aivilon
aivilon 27.10.2014 um 08:19:30 Uhr
Goto Top
Hallo Dieter

Ne nicht ganz. Sie müssten nebeneinander stehen. Das macht mir grad auch von der Logik vom Script zu schaffen. Also alle bisherigen Felder sind ja schon nebeneinander.

Theoretisch würde es den Ort nicht mehrfach brauchen. Da müsste ich ja einfach eine Spalte mit dem ? wieder wegnehmen (respektive mittlerweile 3 :D )

Aber das bzgl. mehrere Suchtreffer hat mich jetzt grad noch auf was aufmerksam gemacht. Wenn ein Benutzer mehrere PCs hat dann ist beim ersten Schluss. Wie müsste ich vorgehen, wenn ich den Benutzer pro PC 1 mal möchte? Die Monitore sollten schlussendlich auch bei jeder Zeile hinten dran stehn.


Grüsse, Pascal
116301
116301 27.10.2014 aktualisiert um 12:20:13 Uhr
Goto Top
Hallo Pascal!

Ne nicht ganz. Sie müssten nebeneinander stehen. Das macht mir grad auch von der Logik vom Script zu schaffen. Also alle bisherigen Felder sind ja schon nebeneinander.
Wie das denn? Nach Deinen Spaltenangaben, müssten die Daten im Sheet Monitor (RngCopyMon/RngCopyMon2) doch eigentlich untereinander stehen...

Vermutlich hast Du den Code noch garnicht getestetface-wink

Wenn Du am Ende im Sheet "Asso..." jeden Benutzer (Ort) nur einmal haben möchtest, dann könntest Du per Spalte Ort alle Duplicate entfernen und das ginge dann z.B. so:
Private Const ColOrtNew = 11

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


Grüße Dieter
aivilon
aivilon 31.10.2014 um 09:21:36 Uhr
Goto Top
Hi Dieter

Funktioniert face-smile
Nur hab ich ein von Excel verursachtes Problem. Excel nimmt auch bei einem For Each Befehl immer den ersten Eintrag. Das heisst konkret bei dem Script:
Für einen PC nimmt er nur den ersten Benutzer den er findet. Nun habe ich Spezialfälle. Zum Beispiel einen Testbenutzer der natürlich auf den selben Arbeitsplatz konfiguriert ist wie der normale Benutzer. Wenn jetzt der Testbenutzer Alphabetisch vor dem Normalen kommt, nimmt er mir für jeden PC am Arbeitsplatz den Testbenutzer.
Kannst du mir einen Tipp geben, wie ich das mit dem Skript hinkriegen würde, dass er für jeden Benutzer, jedes Gerät auflistet?
    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)
                For Each oFound In oCell     ' Im Prinzip sollte doch eine Schleife reichen, die das einfach so lange macht, bis es keine Treffer mehr hat, also bis zum letzten oFound quasi.  
                    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
                Next
            End If
        Next
    End With
116301
116301 31.10.2014 um 11:42:35 Uhr
Goto Top
Hallo aivilon!

Dann ist das PC-Sheet als Basis für die Zusammenfassung wohl der falsche Weg und müsste stattdessen das Benutzer-Sheet seinface-wink

Grüße Dieter
aivilon
aivilon 31.10.2014 um 11:47:07 Uhr
Goto Top
Moinsen Dieter

Ju umschreiben geht. Nur hab ich so rum das selbe Problem. Dann nimmt es mir für jeden Benutzer einfach den ersten gefundenen PC. :/

Grüsse, Aiv
116301
116301 31.10.2014 um 12:44:59 Uhr
Goto Top
Hallo Aiv!

OK, dann wird's äh weng komplizierter und schaue ich mir dann bei Gelegenheit an. Eventuell hat ja auch Uwe (colinardo) Zeit und Lust mich zu vertretenface-smile

Grüße Dieter
116301
Lösung 116301 31.10.2014, aktualisiert am 21.07.2015 um 09:14:39 Uhr
Goto Top
Hallo Aiv!

Sollte dann so gehen:
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 ColOrtNew = 8                 'Assoziation-Ort Spalte H  

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, oWksNew As Worksheet
    Dim oCell As Range, oFound As Range, oNext As Range
    Dim sFirstAddress As String, iRowNext As Long
    
    Set oWksUser = Sheets(SheetUser)
    Set oWksMon = Sheets(SheetMon)
    Set oWksNew = Sheets(SheetNew)
    
    oWksNew.UsedRange.Offset(1).Clear     'New-Sheet zuvor leeren?  
    
    iRowNext = RowStart
    
    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, iRowNext, ColPastePC)
                
                Set oFound = oWksMon.Columns(ColOrtMon).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not oFound Is Nothing Then
                    Call CopyData(SheetMon, RngCopyMon, oFound.Row, iRowNext, ColPasteMon1)
                    
                    Set oNext = oWksMon.Columns(ColOrtMon).FindNext(oFound)
                    If oFound.Address <> oNext.Address Then
                        Call CopyData(SheetMon, RngCopyMon, oNext.Row, iRowNext, ColPasteMon2)
                    End If
                End If
                
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not oFound Is Nothing Then
                    sFirstAddress = oFound.Address
                    Call CopyData(SheetUser, RngCopyUser, oFound.Row, iRowNext, ColPasteUser)
                    
                    Do: Set oFound = oWksUser.Columns(ColOrtUser).FindNext(oFound)
                        If oFound Is Nothing Or oFound.Address = sFirstAddress Then
                            Exit Do
                        Else
                            iRowNext = iRowNext + 1
                            oWksNew.Rows(iRowNext - 1).Copy oWksNew.Rows(iRowNext)
                            Call CopyData(SheetUser, RngCopyUser, oFound.Row, iRowNext, ColPasteUser)
                        End If
                    Loop
                End If
                iRowNext = iRowNext + 1
            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
sofern Deine angegebene Spalten-Überschrift-Reihenfolge stimmen sollte, hast Du hier Spaltendreher drinnen (X/N/P?):
Private Const RngCopyUser = "B,E,F,M,I,J,X,N,P"  


Grüße Dieter