Hallo zusammen,
Ich hoffe, ihr könnt helfen.
Wie schon beschrieben, habe ich eine Arbeitsmappe mit zwei Tabellenblättern, "Mitarbeiter" und Abrechnung".
Im Tabellenblatt "Mitarbeiter" sind die Mitarbeiter mit Personalnummer erfasst und bestimmten Kunden zugeordnet. Hier kann es auch vorkommen, dass ein Mitarbeiter mehreren Kunden zugeordnet ist.
Nun würde ich gerne folgendes erreichen:
Die Kunden sollen aus dem Tabellenblatt "Mitarbeiter" aus Spalte D in das Tabellenblatt Abrechnung kopiert werden. Dabei ist es wichtig, dass der Kunde im Tabellenblatt "Abrechnung" nur einmal kopiert wird und darunter alle Mitarbeiter, die diesem Kunden zugeordnet sind.
Da mit der Arbeitsmappe mehrere Kollegen arbeiten und Formeln dann immer wieder gelöscht werden, habe ich versucht es in VBA zu lösen. Leider stoße ich hier an meine Grenzen.
Ich habe mir bei dem Code folgendes gedacht:
Die Schleife iteriert durch jede Zeile der Quelltabelle, beginnend bei Zeile 5.
Für jede Zeile wird der Wert in Spalte 4 (Kundenname) ausgelesen und überprüft, ob er bereits im Wörterbuch Kundenliste vorhanden ist.
Falls nicht, wird der Wert hinzugefügt und der Kundenname sowie der Wert in Spalte 5 in der Zieltabelle kopiert.
Dann werde die Formatierungen auf die kopierten Zellen angewendet.
Anschließend werden die restlichen Daten aus der Quelltabelle in die Zieltabelle kopiert.
Nachdem ich "Microsoft Scripting Runtime" in den Verweisen aktiviert habe, läuft der Code ohne Fehlermeldungen durch, kopiert aber bedauerlicherweise nichts.
Könnt Ihr mir eventuell weiterhelfen?
Hier der Code:
Code:
Sub ModKopieren()
'Variable für die Quelle Tabelle
Dim sourceSheet As Worksheet
'Variable für die Ziel Tabelle
Dim destSheet As Worksheet
'Variable für die letzte belegte Zeile in Spalte D der Quelle Tabelle
Dim lastRowSource As Long
'Variable für die nächste leere Zeile in Ziel Tabelle
Dim nextEmptyRow As Long
'Variable für den Namen des Kunden
Dim customerName As String
'Variable für eine Liste, die bereits aufgelisteten Kunden enthält
Dim customerList As Scripting.Dictionary
' Quelle Tabelle festlegen
Set sourceSheet = ThisWorkbook.Worksheets("Mitarbeiter")
' Ziel Tabelle festlegen
Set destSheet = ThisWorkbook.Worksheets("Abrechnung")
' Letzte belegte Zeile in Spalte D der Quelle Tabelle suchen
lastRowSource = sourceSheet.Cells(sourceSheet.Rows.Count, "D").End(xlUp).Row
' Nächste leere Zeile in Ziel Tabelle suchen
nextEmptyRow = destSheet.Cells(destSheet.Rows.Count, 1).End(xlUp).Row + 1
' Neue Liste erstellen
Set customerList = New Scripting.Dictionary
' Schleife für jede Zeile von 5 bis letzte belegte Zeile
For i = 5 To lastRowSource
' Kundennamen aus Quelle Tabelle lesen
customerName = sourceSheet.Cells(i, 4).Value
' Prüfen ob der Kundenname noch nicht in der Liste enthalten ist
If Not customerList.Exists(customerName) Then
' Kundennamen zur Liste hinzufügen
customerList.Add customerName, customerName
' Kundennamen in die Ziel Tabelle schreiben
destSheet.Cells(nextEmptyRow, 1).Value = customerName
destSheet.Cells(nextEmptyRow, 2).Value = sourceSheet.Cells(i, 5).Value
' Formatierung für die Zellen
With destSheet.Range("A" & nextEmptyRow & ":B" & nextEmptyRow)
.Font.Bold = True
.Interior.Color = RGB(135, 206, 255)
End With
' Nächste leere Zeile suchen
nextEmptyRow = nextEmptyRow + 1
End If
' Daten in Ziel Tabelle schreiben
destSheet.Cells(nextEmptyRow, 1).Value = sourceSheet.Cells(i, 1).Value
destSheet.Cells(nextEmptyRow, 2).Value = sourceSheet.Cells(i, 2).Value
destSheet.Cells(nextEmptyRow, 3).Value = sourceSheet.Cells(i, 3).Value
nextEmptyRow = nextEmptyRow + 1
Next i
MsgBox "Daten wurden erfolgreich kopiert und sortiert!"
End Sub
Danke und viele Grüße,
Mario
Zellen mit Schleife nach Bedingung kopieren
Kunden Mitarbeiter.xlsx (Größe: 16,17 KB / Downloads: 8)
