Mehrere Zeilen Makieren ( mit Variable )

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub tst() Dim iRow As Long, Datum As String Datum = Format(Date, "dd.mm.yyyy") ' wenn es das heutige Datum sein soll With Worksheets("T_LW_Vorlage") iRow = 5 Do Until IsEmpty(Cells(iRow, 1)) Workbooks.Add xlWBATWorksheet ' neue Mappe mit 1 leerem Tabellenblatt .Range(.Cells(1, 1), .Cells(1, 25)).Copy Cells(1, 1) ' Überschrift .Range(.Cells(iRow, 1), .Cells(iRow, 25)).Copy Cells(2, 1) ' Zeile ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Datum & "\" & .Cells(iRow, 1) ActiveWorkbook.Close iRow = iRow + 1 Loop End With End Sub

Hallo Steffen,
da stellen sich mir ein paar Fragen:
1. Wofür ist "On Error Resume Next" gut? (So würde ich das nie verwenden.)
2. Woher kommt bei dir der Wert von "Datum"?
3. In der Zeile
Dateiname = .Cells(2, 4) & " " & .Cells(2, 24)
wird der Dateiname aus D2 und X2 des Blattes T_LW_Vorlage erzeugt.
Er ändert sich nicht, egal, welche Zeile iRow gerade bearbeitet wird,
es wird also immer wieder unter dem selben Namen gespeichert.
Meinst du das vielleicht ohne die Punkte vor Cells?
Dateiname = Cells(2, 4) & " " & Cells(2, 24)
Dann würden die Zellen D2 und X2 des jeweils aktuellen Blattes verwendet.
4. Verstehe ich das richtig, dass jetzt nicht mehr die Überschrift und eine einzelne Zeile
in einer neuen Mappe gespeichert werden soll, sondern jeweils die Überschrift und
eine Gruppe von Zeilen mit gleicher VL-Nummer (in Spalte X)?
Ist dafür das Quellblatt nach Spalte X sortiert?
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Option Explicit Sub tst3() Dim iRow As Long, Datum As String, lngP As Long Datum = Format(Date, "dd.mm.yyyy") ' wenn es das heutige Datum sein soll With Worksheets("T_LW_Vorlage") .Select iRow = 2 Do Until IsEmpty(Cells(iRow, 1)) Workbooks.Add xlWBATWorksheet ' neue Mappe mit 1 leerem Tabellenblatt .Range(.Cells(1, 1), .Cells(1, 25)).Copy Cells(1, 1) ' Überschrift lngP = 0 ' Anzahl Zeilen bestimmen While .Cells(iRow, 24) = .Cells(iRow + lngP + 1, 24) lngP = lngP + 1 Wend .Range(.Cells(iRow, 1), .Cells(iRow + lngP, 25)).Copy Cells(2, 1) ' Zeile(n) ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Datum & "\" & _ Cells(2, 4) & " " & Cells(2, 24) ActiveWorkbook.Close iRow = iRow + lngP + 1 Loop End With Cells(1, 1).Select End Sub

Option Explicit Sub tst4() Dim iRow As Long, lngP As Long With Worksheets("T_LW_Vorlage") .Select .Cells(1, 1).Select iRow = 2 Do Until IsEmpty(.Cells(iRow, 1)) Workbooks.Add xlWBATWorksheet ' neue Mappe mit 1 leerem Tabellenblatt .Range(.Cells(1, 1), .Cells(1, 25)).Copy Cells(1, 1) ' Überschrift lngP = 0 ' Anzahl Zeilen bestimmen While .Cells(iRow, 24) = .Cells(iRow + lngP + 1, 24) lngP = lngP + 1 Wend .Range(.Cells(iRow, 1), .Cells(iRow + lngP, 25)).Copy Cells(2, 1) ' Zeile(n) On Error Resume Next ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Format(Date, "yyyy-mm-dd") & _ "\" & Cells(2, 4) & " " & Cells(2, 24) On Error GoTo 0 ActiveWorkbook.Close iRow = iRow + lngP + 1 Loop End With End Sub

Hi Steffen,
das mit dem Fehler 1004 verstehe ich nicht - dafür stand vor dem SaveAs doch "On Error Resume Next".
Besser ist es ohnehin, ohne diese Fehlersteuerung auszukommen.
Ob unter dem Namen schon eine Datei existiert, kann man vor dem Speicherversuch prüfen.
Das macht die Version 5:


Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" _
(ByVal PFAD As String) As Long
Sub tst5()
Dim iRow As Long, lngP As Long, strN As String, intE As Integer, strPath As String
strPath = ThisWorkbook.Path & "\" & Format(Date, "yyyy-mm-dd") & "\"
If MakeSureDirectoryPathExists(strPath) = 0 Then
MsgBox "Das Verzeichnis" & vbLf & strPath & vbLf _
& "konnte nicht erstellt werden!", vbCritical, "Abbruch"
Exit Sub
End If
With Worksheets("T_LW_Vorlage")
.Select
.Cells(1, 1).Select
iRow = 2
Do Until IsEmpty(.Cells(iRow, 1))
Workbooks.Add xlWBATWorksheet       ' neue Mappe mit 1 leerem Blatt
.Range(.Cells(1, 1), .Cells(1, 25)).Copy Cells(1, 1)              ' Überschrift
lngP = 0                            ' Anzahl Zeilen bestimmen
While .Cells(iRow, 24) = .Cells(iRow + lngP + 1, 24)
lngP = lngP + 1
Wend
.Range(.Cells(iRow, 1), .Cells(iRow + lngP, 25)).Copy Cells(2, 1) ' Zeile(n)
'                                   ' speichern
strN = strPath & Cells(2, 4) & " " & Cells(2, 24)
If UCase(Right(strN, 4))  ".xls" Then strN = strN & ".xls"
If Dir(strN) > "" Then
intE = MsgBox(strN & vbLf & "existiert bereits." & vbLf & vbLf _
& "Soll die Datei überschrieben werden?", vbYesNoCancel + vbQuestion)
Select Case intE
Case vbYes
Kill strN
ActiveWorkbook.SaveAs strN
ActiveWorkbook.Close
Case vbCancel
Exit Sub
Case Else ' bei "Nein" wird die Mappe nicht gespeichert und bleibt offen
End Select
Else
ActiveWorkbook.SaveAs strN
ActiveWorkbook.Close
End If
iRow = iRow + lngP + 1
Loop
End With
End Sub

Das kannst du gleich in der Mappe ausprobieren:
https://www.herber.de/bbs/user/48698.xls
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

Mehrere Zeilen Makieren ( mit Variable )

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread