Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

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

Frage Entwicklung VB for Applications

Mitglied: aivilon

aivilon (Level 1) - Jetzt verbinden

01.10.2014, aktualisiert 02.10.2014, 1899 Aufrufe, 18 Kommentare

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


Ich danke im Vorraus!


Grüsse Aivilon
Mitglied: colinardo
01.10.2014, aktualisiert 02.10.2014
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
Bitte warten ..
Mitglied: Eintagsfliege
LÖSUNG 01.10.2014, aktualisiert 02.10.2014
Hallo Aivilon!

Und per VBA in etwa so:
01.
Option Explicit 
02.
 
03.
Private Const SheetUser = "Benutzer"        'Tabellenname Benutzer 
04.
Private Const SheetPC = "PC"                'Tabellenname PC 
05.
 
06.
Private Const ColOrtUser = 14               'Benutzer-Ort Spalte N 
07.
Private Const ColOrtPC = 2                  'PC-Ort Spalte B 
08.
 
09.
Private Const ColPastePC = 5                'PC-Paste ab Spalte E 
10.
Private Const RowStartPC = 2                'PC-Ort ab Zeile 2 
11.
 
12.
Private Const RngCopyUser = "B?,E?,F?,I?,J?,N?,P?" 
13.
 
14.
Public Sub CopyUserData() 
15.
    Dim oWksUser As Worksheet, oCell As Range, oFound As Range 
16.
     
17.
    Set oWksUser = Sheets(SheetUser) 
18.
     
19.
    With Sheets(SheetPC) 
20.
        For Each oCell In .Cells(RowStartPC, ColOrtPC).Resize(.UsedRange.Rows.Count, 1) 
21.
            If oCell.Text <> "" Then 
22.
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
23.
                If oFound Is Nothing Then 
24.
                    MsgBox "Ort nicht gefunden: " & oCell.Value, vbInformation, "Ort-Suche..." 
25.
                Else 
26.
                   oWksUser.Range(Replace(RngCopyUser, "?", oFound.Row)).Copy .Cells(oCell.Row, ColPastePC) 
27.
                End If 
28.
            End If 
29.
        Next 
30.
    End With 
31.
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 anpassen


Grüße Dieter
Bitte warten ..
Mitglied: aivilon
01.10.2014, aktualisiert um 13:50 Uhr
Hallo Dieter

Erst mal schon ein Danke!

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

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...

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...):
01.
Option Explicit 
02.
 
03.
Private Const SheetUser = "Benutzer"        'Tabellenname Benutzer 
04.
Private Const SheetPC = "PC"                'Tabellenname PC 
05.
Private Const SheetNew = "Tabelle1"         'Tabellenname Tabelle1 
06.
 
07.
Private Const ColOrtUser = 14               'Benutzer-Ort Spalte N 
08.
Private Const ColOrtPC = 2                  'PC-Ort Spalte B 
09.
 
10.
Private Const ColPastePC = 1                'PC-Paste ab Spalte A 
11.
Private Const ColPastePC = 5                'PC-Paste ab Spalte E 
12.
Private Const RowStartPC = 2                'PC-Ort ab Zeile 2 
13.
 
14.
Private Const RngCopyUser = "B?,E?,F?,I?,J?,N?,P?" 
15.
 
16.
Public Sub CopyUserData() 
17.
    Dim oWksUser As Worksheet, oWksNew As Worksheet, oCell As Range, oFound As Range 
18.
     
19.
    Set oWksUser = Sheets(SheetUser) 
20.
    Set oWksNew = Sheets(SheetNew) 
21.
     
22.
    With Sheets(SheetPC) 
23.
        For Each oCell In .Cells(RowStartPC, ColOrtPC).Resize(.UsedRange.Rows.Count, 1) 
24.
            If oCell.Text <> "" Then 
25.
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
26.
                If oFound Is Nothing Then 
27.
                    oWksNew.Range(Replace(RngCopyUser, "?", oFound.Row)).Copy .Cells(oCell.Row, ColPaste) 
28.
                    'MsgBox "Ort nicht gefunden: " & oCell.Value, vbInformation, "Ort-Suche..." 
29.
                Else 
30.
                   oWksNew.Range(Replace(RngCopyUser, "?", oFound.Row)).Copy .Cells(oCell.Row, ColPastePC) 
31.
                End If 
32.
            End If 
33.
        Next 
34.
    End With 
35.
End Sub
Bitte warten ..
Mitglied: Eintagsfliege
LÖSUNG 01.10.2014, aktualisiert 02.10.2014
Hallo Pascal!

In neues Sheet (Tabelle1) dann in etwa so:
01.
Option Explicit 
02.
 
03.
Private Const SheetUser = "Benutzer"        'Tabellenname Benutzer 
04.
Private Const SheetPC = "PC"                'Tabellenname PC 
05.
Private Const SheetNew = "Tabelle1"         'Tabellenname Tabelle1 
06.
 
07.
Private Const ColOrtUser = 14               'Benutzer-Ort Spalte N 
08.
Private Const ColOrtPC = 2                  'PC-Ort Spalte B 
09.
 
10.
Private Const ColPastePC = 1                'New-Paste PC ab Spalte A 
11.
Private Const ColPasteUser = 5              'New-Paste User ab Spalte E 
12.
 
13.
Private Const RowStart = 2                  'PC-Sheet ab Zeile 2 
14.
 
15.
Private Const RngCopyPC = "A?,B?,C?,F?" 
16.
Private Const RngCopyUser = "B?,E?,F?,I?,J?,N?,P?" 
17.
 
18.
Public Sub CopyUserData() 
19.
    Dim oWksUser As Worksheet, oWksNew As Worksheet, oCell As Range, oFound As Range 
20.
     
21.
    Set oWksUser = Sheets(SheetUser) 
22.
    Set oWksNew = Sheets(SheetNew) 
23.
     
24.
    With Sheets(SheetPC) 
25.
        For Each oCell In .Cells(RowStart, ColOrtPC).Resize(.UsedRange.Rows.Count, 1) 
26.
            If oCell.Text <> "" Then 
27.
               .Range(Replace(RngCopyPC, "?", oCell.Row)).Copy oWksNew.Cells(oCell.Row, ColPastePC) 
28.
                 
29.
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
30.
                If Not oFound Is Nothing Then 
31.
                    oWksUser.Range(Replace(RngCopyUser, "?", oFound.Row)).Copy oWksNew.Cells(oCell.Row, ColPasteUser) 
32.
                End If 
33.
            End If 
34.
        Next 
35.
    End With 
36.
End Sub
Grüße Dieter
Bitte warten ..
Mitglied: aivilon
02.10.2014 um 11:41 Uhr
Du bist super! Funktioniert super! Ich danke dir herzlich für die schnelle Hilfe!!

Ist genau das und macht genau das wo es soll

Danke Danke Danke!


Gruess, Pascal
Bitte warten ..
Mitglied: Eintagsfliege
02.10.2014 um 12:22 Uhr
Hallo Pascal!

Gerne doch

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

Grüße Dieter
Bitte warten ..
Mitglied: colinardo
02.10.2014, aktualisiert um 19:57 Uhr
Zitat von aivilon:
Danke Danke Danke!
ich bedanke mich auch für das kommentarlose Ignorieren .

Gruß Uwe
Bitte warten ..
Mitglied: aivilon
24.10.2014 um 16:59 Uhr
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:

01.
Option Explicit 
02.
 
03.
Private Const SheetUser = "Benutzer"        'Tabellenname Benutzer 
04.
Private Const SheetPC = "PC"                'Tabellenname PC 
05.
Private Const SheetMon = "Monitore"         'Tabellenname Monitore 
06.
Private Const SheetNew = "Assoziation"      'Tabellenname Tabelle1 
07.
 
08.
Private Const ColOrtUser = 14               'Benutzer-Ort Spalte N 
09.
Private Const ColOrtPC = 2                  'PC-Ort Spalte B 
10.
Private Const ColOrtMon = 6                 'Monitore-Ort Spalte F 
11.
Private Const ColOrtMon2 = 6                 'Monitore-Ort Spalte F 
12.
 
13.
Private Const ColPastePC = 10               'New-Paste PC ab Spalte I 
14.
Private Const ColPasteUser = 1              'New-Paste User ab Spalte A 
15.
Private Const ColPasteMon = 14              'New-Paste Monitore ab Spalte N 
16.
Private Const ColPasteMon2 = 17             'New-Paste Monitore ab Spalte Q 
17.
 
18.
Private Const RowStart = 2                  'User-Sheet ab Zeile 2 
19.
 
20.
Private Const RngCopyPC = "A?,B?,C?,F?" 
21.
Private Const RngCopyUser = "B?,E?,F?,M?,I?,J?,X?,N?,P?" 
22.
Private Const RngCopyMon = "B?,E?,F?" 
23.
Private Const RngCopyMon2 = "B?,E?,F?" 
24.
 
25.
 
26.
 
27.
 
28.
Public Sub CopyUserData() 
29.
    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 
30.
     
31.
    Set oWksPC = Sheets(SheetPC) 
32.
    Set oWksNew = Sheets(SheetNew) 
33.
    Set oWksMon = Sheets(SheetMon) 
34.
    Set oWksMon2 = Sheets(SheetMon) 
35.
     
36.
    Range("A2:S3000").Clear 
37.
     
38.
    With Sheets(SheetUser) 
39.
        For Each oCell In .Cells(RowStart, ColOrtUser).Resize(.UsedRange.Rows.Count, 1) 
40.
            If oCell.Text <> "" Then 
41.
               .Range(Replace(RngCopyUser, "?", oCell.Row)).Copy oWksNew.Cells(oCell.Row, ColPasteUser) 
42.
                 
43.
                Set oFound = oWksPC.Columns(ColOrtPC).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
44.
                If Not oFound Is Nothing Then 
45.
                    oWksPC.Range(Replace(RngCopyPC, "?", oFound.Row)).Copy oWksNew.Cells(oCell.Row, ColPastePC) 
46.
                End If 
47.
                 
48.
 
49.
                Set Monfound = oWksMon.Columns(ColOrtMon).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
50.
                If Not Monfound Is Nothing Then 
51.
                    If Not oWksMon.Range Is Nothing Then 
52.
                        oWksMon.Range(Replace(RngCopyMon, "?", Monfound.Row)).Copy oWksNew.Cells(oCell.Row, ColPasteMon) 
53.
                            Set Mon2Found = oWksMon2.Columns(ColOrtMon2).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
54.
                            If Not Mon2Found Is Nothing Then 
55.
                                If Not oWksMon2.Range Is Nothing Then 
56.
                                    oWksMon2.Range(Replace(RngCopyMon2, "?", Mon2Found.Row)).Copy oWksNew.Cells(oCell.Row, ColPasteMon2) 
57.
                            End If 
58.
                End If 
59.
                 
60.
            End If 
61.
        Next 
62.
    End With 
63.
     
64.
End Sub
Meine Logik ist, einfach unter dem oFound, wo die PCs hinter die Benutzer gehängt werden (Jap ich hab das Script umgemoddelt ), 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 ...

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
Bitte warten ..
Mitglied: aivilon
24.10.2014 um 16:59 Uhr
Sorry Uwe, aus Euphorie übersehen.
Bitte warten ..
Mitglied: Eintagsfliege
25.10.2014 um 18:10 Uhr
Hallo aivilon !

Zunächst wäre erstmal zu klären, ob Du tatsächlich nach diesem Muster kopieren willst:
01.
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:
01.
Private Const SheetNew = "Assoziation" 
02.
 
03.
Private Const ColPastePC = 1 
04.
 
05.
Private Const RngCopyUser = "B,E,F,M,I,J,X,N,P" 
06.
 
07.
Private Sub Test() 
08.
    Dim oWksNew As Worksheet, aColumns As Variant, iRow As Long, i As Long 
09.
     
10.
    Set oWksNew = Sheets(SheetNew) 
11.
     
12.
    aColumns = Split(RngCopyUser, ",")  'In einzelne Spalten splitten 
13.
     
14.
    iRow = 20    'Alias Found.Row 
15.
     
16.
    With Sheets(SheetPC).Rows(iRow) 
17.
        For i = 0 To UBound(aColumns)  'Spalten einzeln kopieren 
18.
            .Columns(aColumns(i)).Copy oWksNew.Cells(iRow, ColPastePC).Offset(0, i) 
19.
        Next 
20.
    End With 
21.
End Sub
Grüße Dieter
Bitte warten ..
Mitglied: Eintagsfliege
LÖSUNG 26.10.2014, aktualisiert 31.10.2014
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:
01.
Option Explicit 
02.
Option Compare Text 
03.
 
04.
Private Const SheetPC = "PC"                'Tabellenname PC 
05.
Private Const SheetUser = "Benutzer"        'Tabellenname Benutzer 
06.
Private Const SheetMon = "Monitore"         'Tabellenname Monitore 
07.
Private Const SheetNew = "Assoziation"      'Tabellenname Neu 
08.
 
09.
Private Const ColOrtPC = 2                  'PC-Ort Spalte B 
10.
Private Const ColOrtUser = 14               'Benutzer-Ort Spalte N 
11.
Private Const ColOrtMon = 6                 'Monitore-Ort Spalte F 
12.
 
13.
Private Const ColPasteUser = 1              'New-Paste User ab Spalte A 
14.
Private Const ColPastePC = 10               'New-Paste PC ab Spalte J 
15.
Private Const ColPasteMon1 = 14             'New-Paste Monitore ab Spalte N 
16.
Private Const ColPasteMon2 = 17             'New-Paste Monitore ab Spalte Q 
17.
 
18.
Private Const RowStart = 2                  'Daten ab Zeile 2 
19.
 
20.
Private Const RngCopyPC = "A,B,C,F" 
21.
Private Const RngCopyUser = "B,E,F,M,I,J,X,N,P" 
22.
Private Const RngCopyMon = "B,E,F" 
23.
 
24.
Public Sub CopyDataNewSheet() 
25.
    Dim oWksUser As Worksheet, oWksMon As Worksheet 
26.
    Dim oCell As Range, oFound As Range, oNext As Range 
27.
     
28.
    Sheets(SheetNew).UsedRange.Offset(1).Clear     'New-Sheet zuvor leeren? 
29.
     
30.
    Set oWksUser = Sheets(SheetUser) 
31.
    Set oWksMon = Sheets(SheetMon) 
32.
     
33.
    With Sheets(SheetPC) 
34.
        For Each oCell In .Cells(RowStart, ColOrtPC).Resize(.UsedRange.Rows.Count, 1) 
35.
            If oCell.Text <> "" Then 
36.
                Call CopyData(SheetPC, RngCopyPC, oCell.Row, oCell.Row, ColPastePC) 
37.
                
38.
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
39.
                If Not oFound Is Nothing Then 
40.
                    Call CopyData(SheetUser, RngCopyUser, oFound.Row, oCell.Row, ColPasteUser) 
41.
                End If 
42.
             
43.
                Set oFound = oWksMon.Columns(ColOrtMon).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
44.
                If Not oFound Is Nothing Then 
45.
                    Call CopyData(SheetMon, RngCopyMon, oFound.Row, oCell.Row, ColPasteMon1) 
46.
                     
47.
                    Set oNext = oWksMon.Columns(ColOrtMon).FindNext(oFound) 
48.
                    If oFound.Address <> oNext.Address Then 
49.
                        Call CopyData(SheetMon, RngCopyMon, oNext.Row, oCell.Row, ColPasteMon2) 
50.
                    End If 
51.
                End If 
52.
            End If 
53.
        Next 
54.
    End With 
55.
End Sub 
56.
 
57.
Private Sub CopyData(ByRef sSheet, ByRef sArea, ByVal iRowCopy As Long, _ 
58.
                     ByVal iRowPaste As Long, ByVal iColPaste As Long) 
59.
     
60.
    Dim oCellsPaste As Range, aColumns As Variant, i As Long 
61.
     
62.
    aColumns = Split(sArea, ",") 
63.
     
64.
    Set oCellsPaste = Sheets(SheetNew).Cells(iRowPaste, iColPaste) 
65.
     
66.
    With Sheets(sSheet).Rows(iRowCopy) 
67.
        For i = 0 To UBound(aColumns) 
68.
            .Columns(aColumns(i)).Copy oCellsPaste.Offset(0, i) 
69.
        Next 
70.
    End With 
71.
End Sub
Wobei ich mich schon frage, warum der Ort in einer Zeile gleich mehrfach stehen muss?

Grüße Dieter
Bitte warten ..
Mitglied: aivilon
27.10.2014 um 08:19 Uhr
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
Bitte warten ..
Mitglied: Eintagsfliege
27.10.2014, aktualisiert um 12:20 Uhr
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 getestet

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:
01.
Private Const ColOrtNew = 11 
02.
 
03.
Sheets(SheetNew).UsedRange.RemoveDuplicates Columns:=ColOrtNew, Header:=xlYes

Grüße Dieter
Bitte warten ..
Mitglied: aivilon
31.10.2014 um 09:21 Uhr
Hi Dieter

Funktioniert
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?
01.
    With Sheets(SheetPC) 
02.
        For Each oCell In .Cells(RowStart, ColOrtPC).Resize(.UsedRange.Rows.Count, 1) 
03.
            If oCell.Text <> "" Then 
04.
                Call CopyData(SheetPC, RngCopyPC, oCell.Row, oCell.Row, ColPastePC) 
05.
                
06.
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, lookat:=xlWhole) 
07.
                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. 
08.
                    If Not oFound Is Nothing Then 
09.
                        Call CopyData(SheetUser, RngCopyUser, oFound.Row, oCell.Row, ColPasteUser) 
10.
                    End If 
11.
             
12.
                    Set oFound = oWksMon.Columns(ColOrtMon).Find(oCell.Value, LookIn:=xlValues, lookat:=xlWhole) 
13.
                    If Not oFound Is Nothing Then 
14.
                        Call CopyData(SheetMon, RngCopyMon, oFound.Row, oCell.Row, ColPasteMon1) 
15.
                     
16.
                        Set oNext = oWksMon.Columns(ColOrtMon).FindNext(oFound) 
17.
                        If oFound.Address <> oNext.Address Then 
18.
                            Call CopyData(SheetMon, RngCopyMon, oNext.Row, oCell.Row, ColPasteMon2) 
19.
                        End If 
20.
                    End If 
21.
                Next 
22.
            End If 
23.
        Next 
24.
    End With 
25.
 
Bitte warten ..
Mitglied: Eintagsfliege
31.10.2014 um 11:42 Uhr
Hallo aivilon!

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

Grüße Dieter
Bitte warten ..
Mitglied: aivilon
31.10.2014 um 11:47 Uhr
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
Bitte warten ..
Mitglied: Eintagsfliege
31.10.2014 um 12:44 Uhr
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 vertreten

Grüße Dieter
Bitte warten ..
Mitglied: Eintagsfliege
LÖSUNG 31.10.2014, aktualisiert 21.07.2015
Hallo Aiv!

Sollte dann so gehen:
01.
Option Explicit 
02.
Option Compare Text 
03.
 
04.
Private Const SheetPC = "PC"                'Tabellenname PC 
05.
Private Const SheetUser = "Benutzer"        'Tabellenname Benutzer 
06.
Private Const SheetMon = "Monitore"         'Tabellenname Monitore 
07.
Private Const SheetNew = "Assoziation"      'Tabellenname Neu 
08.
 
09.
Private Const ColOrtPC = 2                  'PC-Ort Spalte B 
10.
Private Const ColOrtUser = 14               'Benutzer-Ort Spalte N 
11.
Private Const ColOrtMon = 6                 'Monitore-Ort Spalte F 
12.
Private Const ColOrtNew = 8                 'Assoziation-Ort Spalte H 
13.
 
14.
Private Const ColPasteUser = 1              'New-Paste User ab Spalte A 
15.
Private Const ColPastePC = 10               'New-Paste PC ab Spalte J 
16.
Private Const ColPasteMon1 = 14             'New-Paste Monitore ab Spalte N 
17.
Private Const ColPasteMon2 = 17             'New-Paste Monitore ab Spalte Q 
18.
 
19.
Private Const RowStart = 2                  'Daten ab Zeile 2 
20.
 
21.
Private Const RngCopyPC = "A,B,C,F" 
22.
Private Const RngCopyUser = "B,E,F,M,I,J,X,N,P" 
23.
Private Const RngCopyMon = "B,E,F" 
24.
 
25.
Public Sub CopyDataNewSheet() 
26.
    Dim oWksUser As Worksheet, oWksMon As Worksheet, oWksNew As Worksheet 
27.
    Dim oCell As Range, oFound As Range, oNext As Range 
28.
    Dim sFirstAddress As String, iRowNext As Long 
29.
     
30.
    Set oWksUser = Sheets(SheetUser) 
31.
    Set oWksMon = Sheets(SheetMon) 
32.
    Set oWksNew = Sheets(SheetNew) 
33.
     
34.
    oWksNew.UsedRange.Offset(1).Clear     'New-Sheet zuvor leeren? 
35.
     
36.
    iRowNext = RowStart 
37.
     
38.
    With Sheets(SheetPC) 
39.
        For Each oCell In .Cells(RowStart, ColOrtPC).Resize(.UsedRange.Rows.Count, 1) 
40.
            If oCell.Text <> "" Then 
41.
                Call CopyData(SheetPC, RngCopyPC, oCell.Row, iRowNext, ColPastePC) 
42.
                 
43.
                Set oFound = oWksMon.Columns(ColOrtMon).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
44.
                If Not oFound Is Nothing Then 
45.
                    Call CopyData(SheetMon, RngCopyMon, oFound.Row, iRowNext, ColPasteMon1) 
46.
                     
47.
                    Set oNext = oWksMon.Columns(ColOrtMon).FindNext(oFound) 
48.
                    If oFound.Address <> oNext.Address Then 
49.
                        Call CopyData(SheetMon, RngCopyMon, oNext.Row, iRowNext, ColPasteMon2) 
50.
                    End If 
51.
                End If 
52.
                 
53.
                Set oFound = oWksUser.Columns(ColOrtUser).Find(oCell.Value, LookIn:=xlValues, LookAt:=xlWhole) 
54.
                If Not oFound Is Nothing Then 
55.
                    sFirstAddress = oFound.Address 
56.
                    Call CopyData(SheetUser, RngCopyUser, oFound.Row, iRowNext, ColPasteUser) 
57.
                     
58.
                    Do: Set oFound = oWksUser.Columns(ColOrtUser).FindNext(oFound) 
59.
                        If oFound Is Nothing Or oFound.Address = sFirstAddress Then 
60.
                            Exit Do 
61.
                        Else 
62.
                            iRowNext = iRowNext + 1 
63.
                            oWksNew.Rows(iRowNext - 1).Copy oWksNew.Rows(iRowNext) 
64.
                            Call CopyData(SheetUser, RngCopyUser, oFound.Row, iRowNext, ColPasteUser) 
65.
                        End If 
66.
                    Loop 
67.
                End If 
68.
                iRowNext = iRowNext + 1 
69.
            End If 
70.
        Next 
71.
    End With 
72.
End Sub 
73.
 
74.
Private Sub CopyData(ByRef sSheet, ByRef sArea, ByVal iRowCopy As Long, _ 
75.
                     ByVal iRowPaste As Long, ByVal iColPaste As Long) 
76.
     
77.
    Dim oCellsPaste As Range, aColumns As Variant, i As Long 
78.
     
79.
    aColumns = Split(sArea, ",") 
80.
     
81.
    Set oCellsPaste = Sheets(SheetNew).Cells(iRowPaste, iColPaste) 
82.
     
83.
    With Sheets(sSheet).Rows(iRowCopy) 
84.
        For i = 0 To UBound(aColumns) 
85.
            .Columns(aColumns(i)).Copy oCellsPaste.Offset(0, i) 
86.
        Next 
87.
    End With 
88.
End Sub
sofern Deine angegebene Spalten-Überschrift-Reihenfolge stimmen sollte, hast Du hier Spaltendreher drinnen (X/N/P?):
01.
Private Const RngCopyUser = "B,E,F,M,I,J,X,N,P"


Grüße Dieter
Bitte warten ..
Neuester Wissensbeitrag
Humor (lol)

Linkliste für Adventskalender

(3)

Information von nikoatit zum Thema Humor (lol) ...

Ähnliche Inhalte
Heiß diskutierte Inhalte
Windows Server
DHCP Server switchen (25)

Frage von M.Marz zum Thema Windows Server ...

SAN, NAS, DAS
gelöst HP-Proliant Microserver Betriebssystem (14)

Frage von Yannosch zum Thema SAN, NAS, DAS ...

Grafikkarten & Monitore
Win 10 Grafikkarte Crash von Software? (13)

Frage von Marabunta zum Thema Grafikkarten & Monitore ...

Windows 7
Verteillösung für IT-Raum benötigt (12)

Frage von TheM-Man zum Thema Windows 7 ...