Anzeige
Archiv - Navigation
1500to1504
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
Inhaltsverzeichnis

Tabelle in mehreren aufteilen

Tabelle in mehreren aufteilen
29.06.2016 12:31:18
Mamo
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

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

Betreff
Datum
Anwender
Anzeige
AW: Tabelle in mehreren aufteilen
29.06.2016 12:54:04
Zwenn
Hallo Mamo,
Du rauchst also Hilfe ;-) Sorry, zu schöner Vertipper, als nicht drauf einzugehen.
In Deinem Arbeitsblatt sind doch nur 3 Tabellen. Kopiere das Blatt zweimal und lösche einfach jeweils zwei Tabellen. Dann passt Du noch die Blattnamen an und gut ist. Das dauert keine 3 Minuten.
Viele Grüße,
Zwenn

AW: Tabelle in mehreren aufteilen
29.06.2016 13:07:21
baschti007
Guck mal ob das geht ?
Sub xx()
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)
MsgBox (Lastb + 1) / y
Range(.Cells(1 + x, 1), .Cells(y + x, 4)).Copy NewSheet.Range("A1")
x = y + x
NewSheet.Name = NewSheet.Cells(1, 2)
Set NewSheet = Nothing
Next
End With
End Sub

Gruß basti

Anzeige
AW: Tabelle in mehreren aufteilen
29.06.2016 13:26:06
Mamo
Super!
Vielen Dank, das ist das was iuch brauche. Habe eben 98 Tabellen exportiert.
Danke nochmal.

AW: Tabelle in mehreren aufteilen
29.06.2016 15:03:59
Mamo
Danke,
wie kriege die Blätter in pdf (Qualtiät niedrig) ausgedruckt?

AW: Tabelle in mehreren aufteilen
29.06.2016 15:32:04
baschti007
Nicht Professionell aber geht =)
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!") 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.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strOrdner & NewSheet.Name & ".pdf",  _
Quality:= _
xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set NewSheet = Nothing
Next
End With
End Sub

Anzeige
AW: Tabelle in mehreren aufteilen
29.06.2016 15:51:30
baschti007
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

Anzeige
AW: Tabelle in mehreren aufteilen
29.06.2016 16:46:52
Mamo
danke baschti007!!

AW: Tabelle in mehreren aufteilen
29.06.2016 18:47:10
Mamo
Hallo,
ein klrines problem habe ich noch. In der Testdatei sind in manchen Zellen in den Splaten "Anzahl und Anzahl der Spalten (%)" sondern haben das Minus-Zeichen ("-"). Wie kann ich diese Zeilen löschen?
Danke

AW: Tabelle in mehreren aufteilen
29.06.2016 19:02:56
Mamo
Hallo,
ein kleines problem habe ich noch. In der Testdatei sind in manchen Zellen in den Splaten "Anzahl und Anzahl der Spalten (%)" sondern haben das Minus-Zeichen ("-"). Wie kann ich diese Zeilen löschen?
Danke

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
Anzeige

301 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige