Hey Leute,
ich habe da ein Problem. Ich möchte mittels VBA ein Programm schreiben, dass aus einer Excel Tabelle mit verschiedenen Datums und Uhrzeiten (Spalte A) einzelne Excel Tabellen erstellt und die Datums mit ganzer Zeile reinkopiert. Die neuen Excel Tabellen sollen jeweils von einem Tag (0-23,59Uhr, wenn vorhanden) die Datums einspeichern. Die Excel Tabellen sollen mit dem jeweiligem Tag bezeichnet werden in Form von „JJJJMMTT.xls“.
In Der Spalte A stehen dabei chronologisch geordnete Datums von mehreren Tagen. Jedoch gibt es unregelmäßige Lücken in der Minutenangaben. Man kann also nicht sagen, dass ein Tag aus (24*60) Tagen besteht. Zu jedem Datum in Spalte A soll die ganze Zeile mit kopiert werden.
In Zeile 1 Stehen Überschriften, somit beginnt das Datum erst In Zeile 2. Die Überschriften müssen bei jeder neuen Excel Tabelle mit erhalten bleiben.
Ich habe überlegt, eine Sicherheitskopie zu machen, damit nichts verloren geht. Somit können die kopierten Daten aus meinem Aktiven Worksheet gelöscht werden und der nächste Tag (für das nächste Excel) steht dann in der Zelle A2. Jedoch Funktioniert die Schleife nicht wie geplant. Es wird nur eine Tabelle erstellt und 3 Zeilen kopiert und dann stürzt es bei mir ab.
Es wäre sehr nett, wenn mir dabei jemand helfen kann.
Grüß, Anna
Sub Exceldateien()
'Variablen Declarieren
Dim i As Long
Dim AZeile As Integer
Dim ASpalte As Integer
Dim objExcel As Object
Dim newdate As Date
AZeile = Cells(Rows.Count, 1).End(xlUp).Rows.Row 'Anzahl der Zeilen
ASpalte = Cells(1, Columns.Count).End(xlToLeft).Column 'Anzahl der Spalten
'Ordner für Zielfunktion anlegen
MkDir "C:\XXX\Test" ' Verzeichnis erstellen, in dem die Dateien erstellt werden (entsprechend anpassen)
'Pfad ändern
'Sicherheitskopie
ActiveSheet.Range("A1", ActiveSheet.Cells(AZeile, ASpalte)).Copy 'Zellen kopieren
Workbooks.Add
Range("A1", ActiveSheet.Cells(AZeile, ASpalte)).PasteSpecial 'Zellen einfügen
ActiveWorkbook.SaveAs Filename:= _
"C:\XXX\Test\" & "Sicherheitskopie" & ".xls"
'Pfad ändern
ActiveWorkbook.Close 'gespeichert ohne zu Öffnen
'Zerlegen der Excel-Tabelle in meherer Tabellen mit jeweils einen Tag (namens:JJJJMMTT.xls)
With ActiveSheet
Do Until Range("A2") = " "
i = 2
newdate = Range("A2")
If Format(Cells(i + 1, 1), "YYYYMMDD") = Format(Cells((i), 1), "YYYYMMDD") Then i = i + 1
End If
With ActiveSheet
ActiveSheet.Range("A1", ActiveSheet.Cells(i, ASpalte)).Copy 'Zellen kopieren
Workbooks.Add
Range("A1", ActiveSheet.Cells(i, ASpalte)).PasteSpecial 'Zellen einfügen
ActiveWorkbook.SaveAs Filename:= _
"C:\XXX\Test\" & Format(newdate, "yyyymmdd") & ".xls"
'Pfad ändern
ActiveWorkbook.Close
End With
Range("A2", ActiveSheet.Cells(i, ASpalte)).Delete Shift:=xlUp
Loop
End With
'Ausgabe das Makro beendet ist
MsgBox "Dateien erstellt!"
End Sub
|