Druckformate übernehmen
21.03.2006 10:53:31
petra
ich habe folgenden Problem:
Habe in einem Tabellenblatt eine Liste mit Werten. In Spalte A sind Zahlenwerte, die aufsteigend sortiert sind, aber auch mehrfach vorkommen.
Jetzt habe ich einen Makro, der mir Werte aus den Spalten A bis U für jeden gleichen Zahlenwert kopiert und in ein neues Tabellenblatt hineinkopiert.
Problem ist allerdings, dass das eingerichtete Druckformat nicht mit übernommen wird.
Jetzt würde ich gerne den Makro ergänzen, damit jedes neue Tabellenblatt das gleiche Druckformat hat wie die ursprungstabelle.
kann mir da jemand helfen?
hier der Makro:
Public
Sub Verteilen()
Application.ScreenUpdating = False
Dim nNumber As Integer, actSh As Worksheet
Dim bComplete As Boolean
bComplete = False
Dim i As Long, nStart, nEnd As Long
nNumber = 0
For i = 3 To 65536
If Sheets(2).Cells(i, 1).Value = "" Then
nEnd = i - 1
Exit For
End If
If nNumber <> Sheets(2).Cells(i, 1).Value Then
If Not bComplete Then
' neues sheet anlegen
nNumber = Sheets(2).Cells(i, 1).Value
nStart = i
Set actSh = Sheets.Add(after:=Worksheets(Worksheets.Count))
' sheet benennen
ActiveSheet.Name = Trim(Str(nNumber))
Sheets(2).Range("a1:u2").Copy
ActiveSheet.Range("a1").Select
' überschrift kopieren
ActiveSheet.Paste
bComplete = True
Else
nEnd = i - 1
' das ende eines blockes wurde erreicht
End If
End If
' das trifft nur dann zu, wenn
' obige if bcomplete schleife einmal komplett durch laufen wurd
If nEnd > nStart Then
' block kopieren
Sheets(2).Range("A" + Trim(Str(nStart)) + ":U" + Trim(Str(nEnd))).Copy
ActiveSheet.Range("a3").Select
ActiveSheet.Paste link:=True
Selection.PasteSpecial Paste:=xlFormats
nEnd = 0
nStart = 0
bComplete = False
i = i - 1 'wir sind quasi über das ziel hinausgeschossen
For Spalte = 1 To 23
ActiveSheet.Columns(Spalte).ColumnWidth = Sheets(2).Columns(Spalte).ColumnWidth
Next Spalte
End If
Next i
If nEnd > nStart Then
' block kopieren
Sheets(2).Range("A" + Trim(Str(nStart)) + ":U" + Trim(Str(nEnd))).Copy
ActiveSheet.Range("a3").Select
ActiveSheet.Paste link:=True
Selection.PasteSpecial Paste:=xlFormats
nEnd = 0
nStart = 0
bComplete = False
i = i - 1 'wir sind quasi über das ziel hinausgeschossen
For Spalte = 1 To 23
ActiveSheet.Columns(Spalte).ColumnWidth = Sheets(2).Columns(Spalte).ColumnWidth
Next Spalte
End If
Application.ScreenUpdating = True
Worksheets("Inhaltsverzeichnis").Activate
End Sub
Anzeige