VBA Daten aus einer Tabelle in mehrere überführen
20.01.2020 14:28:06
Gledson
ich bräuchte einmal Hilfe bei einer VBA-Programmierung.
Ich selber habe schon einen Prototypen erstellt durch Internetrecherche und rumprobieren.
VBA-Kenntnisse sind bei mir, wenn überhaupt, nur rudimentär vorhanden.
Im Groben funktioniert das Skript auch. Nun möchte ich meine existente Version gerne als Schleife laufen lassen, sodass die manuelle Wiederholung entfällt. Da stoße ich jedoch an meine Grenzen.
Es gibt eine Ausgangsdatei, die alle relevanten Informationen beinhaltet.
Es gibt ein Kriterium, in diesem Fall einen Namen, nach dem innerhalb dieser Datei gesucht werden soll (z.B. Franz). Alle Zeilen, die in Spalte 11 "Franz" beinhalten, sollen in eine bestehende Datei überführt werden.
Anschließend soll die Schleife nochmal laufen und das Prozedere mit einem weiteren Namen durchführen (z.B. Hans).
Hans und Franz haben in dem Beispiel bereits existente Zieldateien, z.B. Zieldatei-Franz.xlsx, _ Zieldatei-Hans.xlsx. Das ganze soll dann mit 10 verschiedenen Namen durchgeführt werden. Im Gegensatz zu der aktuellen Version wäre die Abwandlung toll, dass das erste Arbeitsblatt der Zieldatei bereinigt wird ab der Überschrift. Das muss ich aktuell auch noch manuell durchführen, bevor ich das Skript in seiner jetzigen Form laufen lasse.
Sub Kopieren()
Dim wbQuelldatei As Workbook
Dim wbZieldatei As Workbook
Dim strPfadQuelle As String
Dim i As Integer
Dim intLastQuelle As Integer
Dim intLastZiel As Integer
strPfadQuelle = "C:\Users\Matze\Desktop\Ausgangsdatei.xlsx"
strPfadZiel = "C:\Users\Matze\Desktop\Zieldatei-Franz.xlsx"
Set wbZieldatei = Workbooks.Open(strPfadZiel)
Set wbQuelldatei = Workbooks.Open(strPfadQuelle)
intLastQuelle = wbQuelldatei.Sheets(1).UsedRange.Rows.Count
'Ermittlung der letzten beschriebenen Zeile (Quelldatei)
intLastZiel = wbZieldatei.Sheets(1).UsedRange.Rows.Count
'Ermittlung der letzten beschriebenen Zeile (Zieldatei)
With wbQuelldatei.Sheets(1)
For i = 1 To intLastQuelle
If .Cells(i, 11).Value = "Franz" Then
.Cells(i, 1).EntireRow.Copy
wbZieldatei.Sheets(1).Cells(intLastZiel + 1, 1).EntireRow.Insert
intLastZiel = intLastZiel + 1
End If
Next i
End With
End Sub
Über eine Hilfe würde ich mich sehr freuen.
Danke im Voraus!