Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 21:26:15
mehrfache Texte finden
19.04.2024 19:41:34
Bei VBA Ausführung Anzeige einfrieren
19.04.2024 17:05:40
Zählen von Zeilen, in denen in bestimmten Bereich Daten sind
19.04.2024 16:34:52
gemeinsamer Filter über drei Spalten
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1660to1664
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1660to1664
1660to1664
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Hilfe bei Loop bitte

Hilfe bei Loop bitte
08.12.2018 22:41:21
Stefan
Hallo liebe Gemeinde,
ich komme einfach nicht weiter und bitte um eure Hilfe.
mit dem unten stehendem Code möchte ich die Tabellenblätter 4 - 10 nacheinander in einem PDF speichern.
So wie er momentan da steht geht er nicht auf das nächste Blatt über. Was mache ich falsch?
Könnt ihr mir bitte weiter helfen ?
Danke euch schon mal im Voraus
For i = 4 To WS_Count
'Worksheets(I).Select
With Worksheets(i)
lzeile = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
lspalte = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Column
With .PageSetup
.PrintArea = Cells(lzeile, lspalte)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&""arial,standard""&6" & "erstellt am: " & Date & " um " & Format(Time, "HH:MM") & _
" Uhr" & " von: " & Application.UserName
.CenterFooter = ""
.RightFooter = ""
End With
End With
If fs.folderexists(pfad) Then
GoTo ergaenzen
Else
Call MakeDir(pfad)
GoTo erzeugen
End If
Next i
Exit Sub
erzeugen:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
datei, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Exit Sub
ergaenzen:
Call MakeDir(pfad2)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
datei2, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Hilfe bei Loop bitte
08.12.2018 22:53:17
Daniel
Hi
hier fehlt vor dem Cells die Tabellenblattangabe 
.PrintArea = Cells(lzeile, lspalte)
hier musst du das ActiveSheet durch das jeweils zu druckende Sheet Worksheets(i) ersetzen. 
ActiveSheet.ExportAsFixedFormat
dadurch dass du das jetzt in einer Schleife durchführst, sind deine Goto-Sprünge jetzt natürlich Unsinns.
Du sollstest dich von den Goto-Sprüngen verabschieden und stattdessen den an dieser Stelle auszuführenden Code direkt einfügen, damit du die Schleife nicht verlassen muss.
Solcher Spaghetti-Code ist eigentlich schon seit den 70igern des letzten Jahrhunderts außer Mode, genauso wie die damaligen Breitcord-Schlaghosen.
sollstest du bei diesem Programmierstil bleiben wollen, müsstest du die Gotos durch GoSubs ersetzen, damit du am Ende des angesprungenen Programmteils wieder mit Return in die Schleife zurückspringen kannst.
Gruß Daniel
Gruß Daniel
Anzeige
AW: Hilfe bei Loop bitte
08.12.2018 23:30:35
Stefan
irgendwie bekomme ich es nicht hin,
hab den Code jetzt so geändert:
Dim pfad As String
Dim pfad2 As String
Dim name As String
Dim name2 As String
Dim Jahr As Integer
Dim datei As String
Dim datei2 As String
Dim fs As Object
Dim lzeile As Long
Dim lspalte As Long
Dim wsn As String
Dim WS_Count As Integer
Dim i As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
wsn = ActiveWorkbook.ActiveSheet.name
name = "KW " & ThisWorkbook.Worksheets("Namen").Range("M2")
name2 = "KW " & ThisWorkbook.Worksheets("Namen").Range("M2") & " am " & Date
Jahr = Year(CDate(ThisWorkbook.Worksheets("Namen").Range("L2")))
pfad = ThisWorkbook.Path & "\" & "Fahrpläne" & "\" & Jahr & "\" & "MO - FR" & "\" & name & "\" & wsn & "\"
pfad2 = ThisWorkbook.Path & "\" & "Fahrpläne" & "\" & Jahr & "\" & "MO - FR" & "\" & name & "\" & "Änderungen" & "\" & wsn & "\"
Set fs = CreateObject("Scripting.FileSystemObject")
datei = pfad & name
datei2 = pfad2 & name2
For i = 4 To WS_Count
With Worksheets(i)
lzeile = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
lspalte = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Column
With .PageSetup
.PrintArea = Worksheets(i).Cells(lzeile, lspalte)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&""arial,standard""&6" & "erstellt am: " & Date & " um " & Format(Time, "HH:MM") & _
" Uhr" & " von: " & Application.UserName
.CenterFooter = ""
.RightFooter = ""
End With
End With
If fs.folderexists(pfad) Then
Call MakeDir(pfad2)
Worksheets(i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
datei2, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Else
Call MakeDir(pfad)
Worksheets(i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
datei, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End If
Next i
Exit Sub
Anzeige
AW: Hilfe bei Loop bitte
08.12.2018 23:37:36
Daniel
es wäre gut, wenn du den Code mit einrückungen erstellst, damit man die Strukturen besser erkennen kann und dann dein Codeteil als "Code" formatierst (text markieren und dann den Button über dem Eingabefenster drücken).
Dann bleiben die Einrückungen auch hier im Forum erhalten.
"irgendwie bekomme ich es nicht hin," ist jetzt als Fehlerbeschreibung nicht besonders aussagekräftig, ungefähr auf dem gleichen Niveau wie die Antwort: "dann machs anders".
achso:
bei .PrintArea = "..." muss ein Text steht, der Zelladresse des zu druckenden Bereichs enthält.
da müsstest du nochmal genauer prüfen und, falls du hilfe brauchst, nochmal genauer beschreiben, was dort hinein geschrieben werden soll.
Gruß daniel
Anzeige
AW: Hilfe bei Loop bitte
09.12.2018 03:57:26
Stefan
der Code macht mich noch IRRE,
er speichert mir das erste Blatt ab und danach legt er es immer unter Änderungen ab.
Es soll aber so sein damit er jedes Blatt einzeln mit dem Blattnamen abspeichert,
nur wenn die Datei vorhanden ist dann soll er unter Änderungen die Datei nochmal ablegen.
Dim pfad As String
Dim pfad2 As String
Dim name As String
Dim name2 As String
Dim Jahr As Integer
Dim datei As String
Dim datei2 As String
Dim fs As Object
Dim lzeile As Long
Dim lspalte As Long
Dim wsn As String
Dim WS_Count As Integer
Dim i As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
wsn = ActiveWorkbook.ActiveSheet.name
name = "KW " & ThisWorkbook.Worksheets("Namen").Range("M2")
name2 = "KW " & ThisWorkbook.Worksheets("Namen").Range("M2") & " am " & Date
Jahr = Year(CDate(ThisWorkbook.Worksheets("Namen").Range("L2")))
pfad = ThisWorkbook.Path & "\" & "Fahrpläne" & "\" & Jahr & "\" & "MO - FR" & "\" & name & "\" & _
wsn & "\"
pfad2 = ThisWorkbook.Path & "\" & "Fahrpläne" & "\" & Jahr & "\" & "MO - FR" & "\" & name & "\"  _
& "Änderungen" & "\" & wsn & "\"
Set fs = CreateObject("Scripting.FileSystemObject")
datei = pfad & name
datei2 = pfad2 & name2
For i = 1 To 8
Worksheets(i).Activate
'Worksheets(i).Range("I6").Select
lzeile = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
lspalte = Worksheets(i).UsedRange.SpecialCells(xlCellTypeLastCell).Column
With Worksheets(i).PageSetup
.PrintArea = Worksheets(i).Cells(lzeile, lspalte)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&""arial,standard""&6" & "erstellt am: " & Date & " um " & Format( _
Time, "HH:MM") & _
" Uhr" & " von: " & Application.UserName
.CenterFooter = ""
.RightFooter = ""
End With
If fs.folderexists(pfad) Then
Call MakeDir(pfad2)
Worksheets(i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
datei2, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Else
Call MakeDir(pfad)
Worksheets(i).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
datei, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End If
Next i
Exit Sub

Anzeige
AW: Hilfe bei Loop bitte
09.12.2018 05:03:06
fcs
Hallo Stefan,
du hast die Struktur in deinem makro immer noch nicht so, dass der Blattname vom Blatt "i" auch in den dateinamen eingebaut wird.
nachfolgend dein makro angepasst - aber nicht getestet.
LG
Franz 
Sub A()
Dim pfadBasis As String
Dim pfad As String
Dim pfad2 As String
Dim name As String
Dim name2 As String
Dim Jahr As Integer
Dim datei As String
Dim datei2 As String
Dim fs As Object
Dim lzeile As Long
Dim lspalte As Long
Dim wsn As String
Dim WS_Count As Integer
Dim i As Integer
Dim wkb As Workbook, wks As Worksheet, wksNamen As Worksheet
Dim sPrintArea As String
Set wksNamen = ThisWorkbook.Worksheets("Namen")
Set wkb = ActiveWorkbook  'oder ThisWorkbook  ?
WS_Count = wkb.Worksheets.Count
name = "KW " & wksNamen.Range("M2")
'in Dateinamen ist Datum in ISO-Schreibweise der Schreibweise in der Systemeinstellung  _
vorzuziehen
name2 = "KW " & wksNamen.Range("M2") & " am " & Format(Date, "YYYY-MM-DD")
Jahr = Year(CDate(wksNamen.Range("L2")))
pfadBasis = ThisWorkbook.Path & "\" & "Fahrpläne" & "\" & Jahr & "\" & "MO - FR" & "\" &  _
name
Set fs = CreateObject("Scripting.FileSystemObject")
For i = 1 To 8
Set wks = wkb.Worksheets(i)
wsn = wks.name
pfad = pfadBasis & "\" & wsn & "\"
pfad2 = pfadBasis & "\" & "Änderungen" & "\" & wsn & "\"
datei = pfad & name & ".pdf"
datei2 = pfad2 & name2 & ".pdf"
With wks
.Activate 'ist ggf. überflüssig
'Worksheets(i).Range("I6").Select
lzeile = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
lspalte = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
sPrintArea = .Range(.Cells(1, 1), .Cells(lzeile, lspalte)).Address '? _
oder steht der zu druckende Zellbereich in Zelle .Cells(lzeile, lspalte)
With .PageSetup
.PrintArea = sPrintArea
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&""arial,standard""&6" & "erstellt am: " & Date & " um " _
& Format(Time, "hh:mm") & " Uhr" & " von: " & Application.UserName
.CenterFooter = ""
.RightFooter = ""
End With
If fs.folderexists(pfad) Then
Call MakeDir(pfad2)
.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
datei2, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
Else
Call MakeDir(pfad)
.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
datei, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
End If
End With 'wks
Next i
Exit Sub
End Sub

Anzeige
AW: Hilfe bei Loop bitte
09.12.2018 05:26:41
Stefan
@ fcs,
danke dir, ich wäre da nie darauf gekommen.
Echt super nochmals Danke an dich und auch an Daniel

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige