Gesamte Zeilen aus anderen Dateien kopieren
16.01.2024 19:03:43
brina
ich muss für eine Arbeitskollegin eine ToDo Listen Übersicht verschiedener Dateien in einer Datei speichern.
Es gibt eine Hauptdatei, in der ersten Tabelle steht die Projektnummer mit dem jeweiligen Speicherort in Spalte C. Diese Datei hat 3 weitere Tabellenblätter "GTD_NextAction", "GTD_Waiting" und "GTD_Deadline" mit jeweils dem gleichen Aufbau der ersten Zeile.
Das Makro soll im ersten Tabellenblatt der Hauptdatei in Spalte C mit dem ersten Pfad in Zelle C2 beginnen und die Datei öffnen.
Im Grunde geht es darum die einzelnen Dateien zu durchsuchen und Zeilenweise ToDos aus verschiedenen Projekten in einer Datei zu speichern.
Die jeweiligen ToDo Listen haben immer die gleiche erste Zeile mit dem Aufbau, genau wie die Tabellenblätter in die die ToDos kopiert werden sollen.
In jeder geöffneten ToDo Datei soll folgendes passieren:
- wenn in Spalte B "N" & in Spalte "H" nicht "erledigt" oder "entfällt" steht soll jede Zeile auf die das zutrifft in die Hauptdatei in das Tabellenblatt "GTD_NextAction" kopiert werden
- wenn in Spalte B "W" & in Spalte "H" nicht "erledigt" oder "entfällt" steht - kopieren ins Tabellenblatt "GTD_Waiting"
- wenn in Spalte G ein Datum eingetragen ist & in Spalte "H" nicht "erledigt" oder "entfällt" steht - kopieren ins Tabellenblatt "GTD_Deadline"
Das soll für jeden Pfad in Spalte C passieren. Wenn auf den Makro Button gedrückt wird, sollen die bisherigen Einträge aus den Tabellenblättern gelöscht werden (außer Zeile 1 natürlich) und die ToDos aktualisiert für alle Projekte wieder eingetragen werden. Oder einfach die Doppelten entfernen?
Ich weiß nicht ob ich da bisher viel zu kompliziert dran gegangen bin.. das ist mein bisheriger Code, die Daten werden kopiert aber immer in die zweite Zeile des jeweiligen Tabellenblattes kopiert.
Kann da jemand weiterhelfen?
Hier liegt die Beispieldatei zum Verständnis: https://www.herber.de/bbs/user/166133.xlsm
Sub ToDo()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim wbOrigin As Workbook
Dim wsOrigin As Worksheet
Dim wsTarget As Worksheet
Dim cellOrigin As Range
Dim cellTarget As Range
Dim filePath As String
Dim nextRow As Long
Dim foundPath As Boolean
' Ursprungsdatei öffnen
Set wbOrigin = ThisWorkbook
Set wsOrigin = wbOrigin.Worksheets("GTD_Projektliste")
Set wsTarget = wbOrigin.Worksheets("GTD_Waiting")
' Vorherige Löschen
wsTarget.Range("A2:I100").Clear
foundPath = False
' Durchsuchen von Spalte C in GTD_Projektliste
For Each cellOrigin In wsOrigin.Range("C2:C100" & wsOrigin.Cells(wsOrigin.Rows.Count, "C").End(xlUp).Row)
filePath = cellOrigin.Value
' Überprüfen, ob der Pfad vorhanden ist
If Len(filePath) > 0 Then
' Neue Datei öffnen
Dim wbNew As Workbook
Set wbNew = Workbooks.Open(filePath)
' Durchsuchen von Spalte B in der neuen Datei
Dim wsNew As Worksheet
Set wsNew = wbNew.Worksheets(1)
For Each cellTarget In wsNew.Range("B1:B" & wsNew.Cells(wsNew.Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeConstants)
' Überprüfen, ob der Buchstabe "W" vorhanden ist
If InStr(1, cellTarget.Value, "W", vbTextCompare) > 0 Then
' Zeile in GTD_NextAction der Ursprungsdatei kopieren
nextRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
cellTarget.EntireRow.Copy wsTarget.Rows(nextRow)
End If
Next cellTarget
' Geschlossene Datei speichern und schließen
wbNew.Close SaveChanges:=False
End If
Next cellOrigin
' Doppelte To Dos entfernen
wsTarget.Range("A2:I1000").RemoveDuplicates Columns:=6
' Ursprungsdatei speichern
wbOrigin.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub