AW: Tabelle in mehreren aufteilen
01.07.2016 09:17:07
baschti007
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