AW: Fortlaufend mehrere Zellen markieren/kopieren
22.09.2018 11:02:29
fcs
Hallo Tobi,
ich habe dein Makro noch ein wenig verfeinert/optimiert:
1. nicht mehr benötigte Variablen Zeilen entfernt (betrifft Variable Zei_Z)
2. Bildschirmaktualisierung zeitweise deaktiviert (verhindert flackern des Bildschirms, Makro wird schneller)
3. Alle Prüfungen der x-Werte in eine For-Next-Schleife gepackt
4. Variablen für die Zieltabellen konsequent verwendet (in Zeile für das Einfügen)
Da ja immer die gleichen Aktionen für die 3 Zielblätter aus geführt werden kann das Ganze auch mit einem Hauptmakro und einem Untermakro lösen. Das Haupmakro ruft das Untermakro 3 mal auf und übergibt dabei als Parameter die sich ändernden Werte (Zieltabelle und Spalte mit "x").
Gruß
Franz
'Makro-Code optimiert/bereinigt
Sub Test_Neu_1()
Dim Zei_Q As Long
Dim wks_Q As Worksheet, wks_Z As Worksheet, wks_U As Worksheet, wks_I As Worksheet
Set wks_Q = ActiveWorkbook.Worksheets("Bearbeiten")
Set wks_Z = ActiveWorkbook.Worksheets("Essen")
Set wks_U = ActiveWorkbook.Worksheets("Schlafen")
Set wks_I = ActiveWorkbook.Worksheets("Schlüssel")
Application.ScreenUpdating = False
With wks_Z
.Range(.Cells(2, 1), .Cells(40, 4)).ClearContents
End With
With wks_U
.Range(.Cells(2, 1), .Cells(40, 4)).ClearContents
End With
With wks_I
.Range(.Cells(2, 1), .Cells(40, 4)).ClearContents
End With
With wks_Q
For Zei_Q = 2 To 40
If .Cells(Zei_Q, 5).Value = ("x") Then 'Tabelle Essen
.Range(.Cells(Zei_Q, 1), .Cells(Zei_Q, 4)).Copy
wks_Z.Cells(wks_Z.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:= _
xlValues
Application.CutCopyMode = False
End If
If .Cells(Zei_Q, 6).Value = ("x") Then 'Tabelle Schlafen
.Range(.Cells(Zei_Q, 1), .Cells(Zei_Q, 4)).Copy
wks_U.Cells(wks_U.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:= _
xlValues
Application.CutCopyMode = False
End If
If .Cells(Zei_Q, 7).Value = ("x") Then 'Tabelle Schlüssel
.Range(.Cells(Zei_Q, 1), .Cells(Zei_Q, 4)).Copy
wks_I.Cells(wks_I.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:= _
xlValues
Application.CutCopyMode = False
End If
Next Zei_Q
End With
Application.ScreenUpdating = True
End Sub
'Variante mit Sub-Routine
Sub Test_Neu_2()
Application.ScreenUpdating = False
With ActiveWorkbook
Call KopierenAktion(wks_Z:=.Worksheets("Essen"), SpaAktion:=5)
Call KopierenAktion(wks_Z:=.Worksheets("Schlafen"), SpaAktion:=6)
Call KopierenAktion(wks_Z:=.Worksheets("Schlüssel"), SpaAktion:=7)
End With
Application.ScreenUpdating = True
End Sub
Sub KopierenAktion(wksZ As Worksheet, SpaAktion As Long)
Dim Zei_Q As Long, Zei_Z As Long
Dim wksQ As Worksheet
Set wks_Q = ActiveWorkbook.Worksheets("Bearbeiten")
With wks_Z
Zei_Z = 1 'Zeile mit Spaltentitel im Zielblatt
.Range(.Cells(Zei_Z + 1, 1), .Cells(40, 4)).ClearContents
End With
With wks_Q
For Zei_Q = 2 To 40
If .Cells(Zei_Q, SpaAktion).Value = ("x") Then
.Range(.Cells(Zei_Q, 1), .Cells(Zei_Q, 4)).Copy
Zei_Z = Zei_Z + 1
wks_Z.Cells(Zei_Z, 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
End If
Next Zei_Q
End With
End Sub