AW: Makro zum kopieren von Bereichen in neue Tabelle
27.09.2009 07:25:50
Bereichen
Hallo Jessi,
da sind sie ja wieder deine berühmten 27 Spalten ;-)
Hier ein Makro zum Kopieren von Zellenblöcken abhängig von Prüf-Kriterien.
Gruß
Franz
Sub BloeckeKopieren()
Dim wksQuelle As Worksheet, SpalteQuelle As Long
Dim wksZiel As Worksheet, SpalteZiel As Long
Dim Zeilen_Block As Long, Zeile_1_Block As Long, SpaltenDaten As Long
Dim Spalte_1_Kategorie As Long, SpaltenKategorie As Long
Dim Zeile_1_Ziel As Long, Spalte_1_Ziel As Long
'Zeilen und Spalten-Daten für Blöcke und Ziel
Zeilen_Block = 44 'Anzahl der Zeilen der zu kopierenden Blöcke
Zeile_1_Block = 1 'Zeilennummer der 1. Zeile der Blöcke
SpaltenKategorie = 5 'Anzahl derKategorie-Spalten
SpaltenDaten = 27 'Anzahl der Spalten mit Daten
Spalte_1_Kategorie = 1 'Spalten-Nummer der 1. Kategorie-Spalte, A=1, B=2, ...
Zeile_1_Ziel = 1 'Zeilennummer der 1. Zeile der Blöcke im Zielblatt
Spalte_1_Ziel = 1 'Spalten-Nummer der 1. Kategorie-Spalte im Zielblatt
Set wksQuelle = ActiveWorkbook.Worksheets("Tabelle1")
Set wksZiel = ActiveWorkbook.Worksheets("Tabelle2")
'Altdaten in Zieltabelle löschen
With wksZiel
.Range(.Cells(Zeile_1_Ziel, Spalte_1_Ziel), _
.Cells(Zeile_1_Ziel + Zeilen_Block - 1, _
Spalte_1_Ziel + SpaltenDaten - 1)).Clear
End With
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With wksQuelle
'die 5 Kategorie-Spalten kopieren
SpalteZiel = Spalte_1_Ziel
.Range(.Cells(Zeile_1_Block, Spalte_1_Kategorie), _
.Cells(Zeile_1_Block + Zeilen_Block - 1, _
Spalte_1_Kategorie + SpaltenKategorie - 1)).Copy
wksZiel.Cells(Zeile_1_Ziel, SpalteZiel).PasteSpecial Paste:=xlPasteFormats
wksZiel.Cells(Zeile_1_Ziel, SpalteZiel).PasteSpecial Paste:=xlPasteValues
'Nicht ausgeblendete Datenspalten kopieren
SpalteZiel = Spalte_1_Ziel + SpaltenKategorie - 1
For SpalteQuelle = SpaltenKategorie + 1 To SpaltenKategorie + SpaltenDaten
'Das Prüfkriterieum für das Kopieren der Daten-Spalten ggf. anpassen
'hier: nur die sichtbaren Spalten kopieren
If .Cells(Zeile_1_Block, SpalteQuelle).EntireColumn.Hidden = False Then
.Range(.Cells(Zeile_1_Block, SpalteQuelle), _
.Cells(Zeile_1_Block + Zeilen_Block - 1, SpalteQuelle)).Copy
SpalteZiel = SpalteZiel + 1
'Formate und Werte kopieren
wksZiel.Cells(Zeile_1_Ziel, SpalteZiel).PasteSpecial Paste:=xlPasteFormats
wksZiel.Cells(Zeile_1_Ziel, SpalteZiel).PasteSpecial Paste:=xlPasteValues
End If
Next
End With
wksZiel.Parent.Activate
wksZiel.Activate
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub