Tabelle in mehreren aufteilen

Mamo · 2016-06-29T12:31:18+00:00

Hallo, ich rauche eure Hilfe; Ich habe mehrere Tabellen, gleich aufgebaut, in einem Excelblatt. Nun möchte ich jede Tabelle in einem Blatt speichern. Das Blatt soll benannt werden nach der Bezeichnung der einzelnen Tabellen, was in Spalte B direkt über die Tabelle (Mathematik, usw) steht. Außerdem möcht ich die einzelne Blätter in PDF umwandeln. https://www.herber.de/bbs/user/106610.xlsm

ups so
sonst kommt ein Fehler beim Abbrechen

Sub xx()
Dim strOrdner As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1)  "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
If strOrdner = "" Then
MsgBox ("Kein Ordner gewählt!")
Exit Sub
Else 'MsgBox strOrdner
With Sheets(1)
y = 102
Dim i As Long
Lastb = .Cells(1048576, 2).End(xlUp).Row
For i = 1 To (Lastb + 1) / y
Set NewSheet = Worksheets.Add
NewSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
Range(.Cells(1 + x, 1), .Cells(y + x, 4)).Copy NewSheet.Range("A1")
x = y + x
NewSheet.Name = NewSheet.Cells(1, 2)
NewSheet.PageSetup.PrintArea = "$A$1:$D$101"
NewSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strOrdner & NewSheet.Name & ".pdf",  _
Quality:= _
xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=false
Set NewSheet = Nothing
Next
End With
End If
End Sub

Es werden alle Zeilen gelöscht wo in Spalte C ein "-" steht

Sub xx()
Dim strOrdner As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1)  "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
If strOrdner = "" Then
MsgBox ("Kein Ordner gewählt!")
Exit Sub
Else 'MsgBox strOrdner
With Sheets(1)
y = 102
Dim i As Long
Lastb = .Cells(1048576, 2).End(xlUp).Row
For i = 1 To (Lastb + 1) / y
Set NewSheet = Worksheets.Add
NewSheet.Move After:=Sheets(ActiveWorkbook.Sheets.Count)
Range(.Cells(1 + x, 1), .Cells(y + x, 4)).Copy NewSheet.Range("A1")
x = y + x
Dim xx, rng As Long
For xx = 3 To 101
If NewSheet.Cells(xx, 3) = "-" Then
Rows(xx).EntireRow.Delete
xx = xx - 1
End If
Next xx
NewSheet.Name = NewSheet.Cells(1, 2)
NewSheet.PageSetup.PrintArea = "$A$1:$D$101"
NewSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strOrdner & NewSheet.Name & ".pdf",  _
_
Quality:= _
xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set NewSheet = Nothing
Next
End With
End If
End Sub

Gruß basti

Forumthread: Tabelle in mehreren aufteilen

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Tabelle in mehreren aufteilen

Forumthread: Tabelle in mehreren aufteilen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread