Tabellenblatt aufteilen

[snb]

oder:

Code:

Sub M_snb()
 sn = Sheets(1).Cells(1).CurrentRegion
 sp = Evaluate("row(1:" & UBound(sn) & ")")
 
 For j = 1 To 18
    Sheets.Add(, Sheets(Sheets.Count)).Cells(1).Resize(UBound(sn), 3) = Application.Index(sn, sp, Array(1, 2, j + 2))
 Next
End Sub

[schauan]

Hallöchen,

hab den Code von snb mal korrigiert (Spalte A-C + eine weitere) und um die Blattnamen und Zeilenhöhen erweitert.

Code:

Sub M_snb()
sn = Sheets(1).Cells(1).CurrentRegion
sp = Evaluate("row(1:" & UBound(sn) & ")")
For j = 1 To 18
Sheets.Add(, Sheets(Sheets.Count)).Cells(1).Resize(UBound(sn), 4) = Application.Index(sn, sp, Array(1, 2, 3, j + 3))
ActiveSheet.Name = Cells(1, 4) & "," & Cells(2, 4)
For k = 1 To UBound(sn)
Cells(k, 1).RowHeight = Sheets(1).Cells(k, 1).RowHeight
Next
Next
End Sub

[coemm]

Hallo André, hallo snb,

leider funktioniert der Code immer noch nicht.

Es wird nur ein Tabellenblatt erstellt, in dem aber die Formatierung komplett "flöten geht".
Außerdem gibt es noch einen Laufzeitfehler.

[schauan]

Hallo Conny,

ja, im Code von snb werden nur die Werte übernommen und sonst nichts. Der von mir geänderte ist aber getestet und läuft und holt zusätzlich die Blattnamen und die Zeilenhöhen. Allerdings hab ich die 18 gelassen und nicht auf 17 "gekürzt".

Dass ist der Teil

Code:

ActiveSheet.Name = Cells(1, 4) & "," & Cells(2, 4)
For k = 1 To UBound(sn)
Cells(k, 1).RowHeight = Sheets(1).Cells(k, 1).RowHeight
Next

und den kannst Du im Prinzip auch in Deinen übernehmen. Ist diesmal aber ungetestet.

Code:

Sub copySheet()
   For i = 1 To 17
      With Sheets(1)
         Worksheets.Add After:=Sheets(Sheets.Count)
         Union(.Range("A:C"), .Columns(i + 3)).Copy Sheets(i + 1).Cells(1, 1)
         ActiveSheet.Name = Cells(1, 4) & "," & Cells(2, 4) 'Name aus D1 und D2 vom neuen Blatt
         For k = 1 To 100 'Wenn es um 100 Zeilen geht ... kann man auch flexibel gestalten.
           Cells(k, 1).RowHeight = .Cells(k, 1).RowHeight
         Next
 
    End With
   Next
End Sub

Allerdings müssen auch genug Einträge in Deiner Quelle sein, sonst gibt es irgendwann auf den neuen Blättern keine Einträge in D1 und D2 und ich schrieb ja schon, dass die Blätter unterschiedliche Namen brauchen ...

[snb]

Deine Post #1:

wobei die Spalten A und B auf jedem Blatt vorhanden sein sollen und dazu jeweils eine weitere Spalte.
Also:
Tabellenblatt 2 mit den Spalten A, B, C
Tabellenblatt 3 mit den Spalten A, B, D

das is genau was

Code:

Sub M_snb()
 sn = Sheets(1).Cells(1).CurrentRegion
 sp = Evaluate("row(1:" & UBound(sn) & ")")
 
 For j = 1 To 18
    Sheets.Add(, Sheets(Sheets.Count)).Cells(1).Resize(UBound(sn), 3) = Application.Index(sn, sp, Array(1, 2, j + 2))
 Next
End Sub

macht.

[schauan]

@snb

ja, aber da gibt es Unterschiede zwischen #1 und #4
Ist vielleicht gewollt, oder auch ein Fehler. Ich hab nun mit #4 weitergemacht.

@Conny,

Außerdem gibt es noch einen Laufzeitfehler.

welchen denn und in welchem bzw. wessen code?

[coemm]

Hallo zusammen,

irgendwie funktioniert der Code nicht.

Ich hänge mal eine verkürzte Beispieldatei an. Das Original hat mehr Spalten (bis R).

Der Code soll das erste Tabellenblatt im Original belassen und zusätzlich weitere Blätter anhängen mit den Spalten
A B C D
A B C E
A B C F
usw. des ersten Tabellenblattes,
sowie das jeweilige Tabellenblatt nach den Namen in den Zeilen 1 und 2 in der Form "Test, Frauke";  "Versuch, Hans" usw. benennen.

Dabei soll die Formatierung (Zeilenhöhe, Spaltenbreite, Blattränder) aber erhalten bleiben.

[snb]

Verwende nie, repeat nie 'merged cells'.

[atilla]

Hallo zusammen,

wenn die Aufgabe immer wieder erledigt werden soll, wovon ich ausgehe, dann würde ich etws mehr Code einsetzen.

Als erstes könnte ich mir vorstellen, dass eventuell schon vorhandene Tabellenblätter gelöscht werden sollen.
Das würde folgender Code machen:

Code:

  Dim i As Long
  Dim wks As Worksheet

  On Error GoTo Fehler_Meldung
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  If MsgBox("Sollen die Tabellenblätter wirklich gelöscht werden?", vbYesNo, "Tabellenblätter löschen?") = vbYes Then
    For Each wks In ThisWorkbook.Sheets
      If wks.Name <> "Bewertung MuG" Then
        wks.Delete
      End If
    Next
  End If
 
Fehler_Meldung:
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  If Err Then MsgBox "Fehler: " & i & "   " & Err.Number & vbLf & Err.Description
End Sub

Mit obiger Routine werden alle Blätte außer Bewertung MuG gelöscht.

Zum Kopieren gehe ich einen ganz anderen Weg als die bisher gezeigten Lösungen.
Ich kopier einfach das ganze Blatt und lösch danach die nicht benötigten Spalten, so werden keine Formate zerschossen.

Und das geschieht dann mit diesem Code:

Code:

Sub Blatt_kopieren()
 Dim i As Long
 Dim wksA As Worksheet
 Set wksA = ActiveSheet
 
 Application.ScreenUpdating = False
  For i = 4 To 20
     wksA.Copy After:=Sheets(Sheets.Count)
     With ActiveSheet
       Select Case i
         Case 4
           .Name = Cells(1, 4) & "," & Cells(2, 4)
           .Range(.Cells(1, i + 1), .Cells(1, 20)).EntireColumn.Delete
        Case 5 To 19
         .Name = Cells(1, i) & "," & Cells(2, i)
           Union(.Range(.Cells(1, 4), .Cells(1, i - 1)), .Range(.Cells(1 + i), .Cells(1, 20))).EntireColumn.Delete
         Case 20
           .Name = Cells(1, 20) & "," & Cells(2, 20)
           .Range(.Cells(1, 4), .Cells(1, 19)).EntireColumn.Delete
      End Select
     End With
  Next
  Application.ScreenUpdating = True
 
End Sub

Das der Code in der Beispieldatei funktioniert, habe ich dem Umstand zu verdanken, dass sich die Verbundenen Zellen nicht im zu löschen Bereich befinden.
Der Code ist statisch auf 20 Spalten eingestellt. Sollte eine flexible Lösung nötig sein, dann müssen im Code einige Anpassungen gemacht werden.

[coemm]

Zum Kopieren gehe ich einen ganz anderen Weg als die bisher gezeigten Lösungen.
Ich kopier einfach das ganze Blatt und lösche danach die nicht benötigten Spalten, so werden keine Formate zerschossen.

Und das geschieht dann mit diesem Code:

Code:

Sub Blatt_kopieren()
 Dim i As Long
 Dim wksA As Worksheet
 Set wksA = ActiveSheet
 
 Application.ScreenUpdating = False
  For i = 4 To 20
     wksA.Copy After:=Sheets(Sheets.Count)
     With ActiveSheet
       Select Case i
         Case 4
           .Name = Cells(1, 4) & "," & Cells(2, 4)
           .Range(.Cells(1, i + 1), .Cells(1, 20)).EntireColumn.Delete
        Case 5 To 19
         .Name = Cells(1, i) & "," & Cells(2, i)
           Union(.Range(.Cells(1, 4), .Cells(1, i - 1)), .Range(.Cells(1 + i), .Cells(1, 20))).EntireColumn.Delete
         Case 20
           .Name = Cells(1, 20) & "," & Cells(2, 20)
           .Range(.Cells(1, 4), .Cells(1, 19)).EntireColumn.Delete
      End Select
     End With
  Next
  Application.ScreenUpdating = True
 
End Sub

Dass der Code in der Beispieldatei funktioniert, habe ich dem Umstand zu verdanken, dass sich die verbundenen Zellen nicht im zu löschenden Bereich befinden.
Der Code ist statisch auf 20 Spalten eingestellt. Sollte eine flexible Lösung nötig sein, dann müssen im Code einige Anpassungen gemacht werden.

Hallo Atilla,

deinen Weg habe ich gestern bei einer Datei noch "zu Fuß" gemacht, da ich die Blätter für heute ausdrucken musste.

Bei meinen weiteren Dateien habe ich deinen Code angewandt. Er funktioniert wunderbar :98: .
Ich musste nur z.B. die 20 auf 18 sowie die 19 auf 17 reduzieren.

Flexible Lösung würde dann wohl bedeuten, dass man z.B. die "20" durch die "letzte belegte Spalte" ersetzt.