Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1644to1648
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

Fortlaufend mehrere Zellen markieren/kopieren

Fortlaufend mehrere Zellen markieren/kopieren
20.09.2018 13:39:24
Tobi
Hallo ich muss 4 Zellen nebeneinander kopieren und das fortlaufend.
Alles in allem bräuchte ich es wie ein ganz normales Array nur halt für Spalten und nicht für Zeilen.
Wie:
Dim i As Varian
For i = 2 To 10
Nur halt für Spalten
Das kommt nämlich in dieses Paket rein:

If Celle(2, 5).Value = ("x") Then
Worksheets("Nr1").Range("A2:D2").Copy
Worksheets("Nr2").Cells(Worksheets("Nr2").Rows.Count, 1).Endlich(xlUp).Offset(1, 0).
PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
End If

Statt dem ersten zweier erste Zeile fortlaufend Zeilen
Und statt A2:D2 das genannte Problem ;)
Es sollen immer diese jeweiligen 4 Zellen A-d der jeweiligen Zeile, ausgewählt werden in dessen Zeile das ("x") steht
LG Tobi

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Fortlaufend mehrere Zellen markieren/kopieren
21.09.2018 00:04:29
fcs
Hallo Tobi,
sollte etwa wie folgt funktionieren.
Gruß
Franz
Sub Test()
Dim Zei_Q As Long, Zei_Z As Long
Dim wks_Q As Worksheet, wks_Z As Worksheet
Set wks_Q = ActiveWorkbook.Worksheets("Nr1")
Set wks_Z = ActiveWorkbook.Worksheets("Nr2")
With wks_Z
Zei_Z = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With wks_Q
For Zei_Q = 2 To 10
If .Cells(Zei_Q, 5).Value = ("x") Then
.Range(.Cells(Zei_Q, 1), .Cells(Zei_Q, 4)).Copy 'Spalten A bis D in der Zeile
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

Anzeige
AW: Fortlaufend mehrere Zellen markieren/kopieren
21.09.2018 15:23:20
Tobi
Hallo Franz
Ich habe noch etwas herumgefeilt und bin nun auf dieses recht zufriedenstellende Ergebnis gekommen.
Falls dir noch weitere Verbesserungsmöglichkeit einfallen, würde mich das freuen.

Sub Test()
Dim Zei_Q1 As Long, Zei_Q2 As Long, Zei_Q3 As Long, Zei_Z 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")
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_Z
Zei_Z = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With wks_Q
For Zei_Q1 = 2 To 40                                        'Tabelle Essen
If .Cells(Zei_Q1, 5).Value = ("x") Then
.Range(.Cells(Zei_Q1, 1), .Cells(Zei_Q1, 4)).Copy
Zei_Z = Zei_Z + 1
wks_Z.Cells(Worksheets("Essen").Rows.Count, 1).End(xlUp).Offset(1, 0). _
PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
End If
Next Zei_Q1
For Zei_Q2 = 2 To 40                                        'Tabelle Schlafen
If .Cells(Zei_Q2, 6).Value = ("x") Then
.Range(.Cells(Zei_Q2, 1), .Cells(Zei_Q2, 4)).Copy
Zei_Z = Zei_Z + 1
wks_U.Cells(Worksheets("Schlafen").Rows.Count, 1).End(xlUp).Offset(1, 0). _
PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
End If
Next Zei_Q2
For Zei_Q3 = 2 To 40                                        'Tabelle Schlüssel
If .Cells(Zei_Q3, 7).Value = ("x") Then
.Range(.Cells(Zei_Q3, 1), .Cells(Zei_Q3, 4)).Copy
Zei_Z = Zei_Z + 1
wks_I.Cells(Worksheets("Schlüssel").Rows.Count, 1).End(xlUp).Offset(1, 0). _
PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
End If
Next Zei_Q3
End With
End Sub

LG Tobi
PS: Das Roh-File das ich gemacht habe schicke ich auch mit, damit du's leichter Testen kannst ;D
https://www.herber.de/bbs/user/124139.xlsm
Anzeige
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

Anzeige
AW: Fortlaufend mehrere Zellen markieren/kopieren
22.09.2018 12:45:46
Tobi
Hallo Franz
Danke für die Verfeinerung, eine frage hab ich noch wo bzw. wie benutze ich:
'Variante mit Sub-Routine
Mir fällt einfach nicht ein wo oder wie ich den Code benutzen soll
Danke nochmals
LG Tobi
AW: Fortlaufend mehrere Zellen markieren/kopieren
22.09.2018 14:42:10
fcs
Hallo Tobi,
die Variante mit Subroutine wird genauso eingesetzt wie die andere Variante mit einem Makro.
Hier wird das Makro "Test_Neu_2" gestartet und dieses ruft dann 3 mal die Subroutine auf mit jeweils anderen Parametern (Tabellenblatt, Spalte mit X).
Gruß
Franz
AW: Fortlaufend mehrere Zellen markieren/kopieren
22.09.2018 16:04:29
Tobi
Hallo Franz
Dies habe ich auch versucht nur bekomme ich immer diese Fehlermeldung
Fehler Beim Kompilieren:
Benanntes Argument nicht gefunden

Er springt dann immer zu dieser Zeile
Call KopierenAktion(wks_Z:=.Worksheets("Essen"), SpaAktion:=5)

Er markiert immer "wks_Z:="
LG Tobi
Anzeige
AW: Fortlaufend mehrere Zellen markieren/kopieren
23.09.2018 08:56:10
Hajo_Zi
Hallo Tobi,
nur wenige schauen auf Deinen Rechner und sehen die Datei.
Ich möchte gerne den Fehler im Original sehen.
Ich baue keine Datei nach. Die Zeit hat schon jemand investiert.
Ein Nachbau sieht meist anders aus als das Original. Darum sollte das Original verlinkt werden.
Wenn du an Stelle einer Demomappe deine Originalmappe hochladen willst, diese aber sensible Daten enthält, kannst du diese Daten anonymisieren bzw. pseudonymisieren.
Benutze hier im Forum die Funktion zum hochladen. Falls Du die nicht benutzen möchtest beachte, von unsicheren Servern wie z.B. www.file-upload.net lade ich keine Datei runter. (lt. Einschätzung meines Virenprogramms)
man könnte vermuten es fehlt ein With.

Beiträge von Werner, Luc, robert, J.O.Maximo und folgende lese ich nicht.
Anzeige
AW: Fortlaufend mehrere Zellen markieren/kopieren
23.09.2018 09:31:33
Tobi
Hallo Hajo
Da ist gleich das erste Problem ich habe leider noch nicht die nötige Sicherheitsfreigabe damit ich die Dateien anleine bearbeiten darf/kann. Aber das Original soll genau so aussehen wie ich es als File hochgeladen werde (ich passe das Original einfach an ;D wenn nicht).
https://www.herber.de/bbs/user/124162.xlsm

Eine Frage ist dann noch wegen dem Zweiten Code den Franz mir gegeben hat, wie kann man den anpassen wenn man mehrere Personenspalten und/oder mehrere X Spalten hinzufügen muss.
Einfach ein weiteres Call dazu und beim If die Cells anpassen?
Danke für die Hilfe
LG Tobi
Anzeige
AW: Fortlaufend mehrere Zellen markieren/kopieren
23.09.2018 09:45:12
Hajo_Zi
HAllo Tobi,
ich kann Dior Leider nicht helfen, was wohl daran liegt das ich die Fehlerhafte Zeile
Call KopierenAktion(wks_Z:=.Worksheets("Essen"), SpaAktion:=5)
nicht finden konnte.
Gruß Hajo
AW: Fortlaufend mehrere Zellen markieren/kopieren
23.09.2018 09:49:30
Tobi
Hallo Hajo
Kopier einfach den Code den Franz reingestellt hat
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

LG Tobi
Anzeige
AW: Fortlaufend mehrere Zellen markieren/kopieren
23.09.2018 11:09:03
Gerd
Hallo Tobi,
bei der Zeile
Sub KopierenAktion(wksZ As Worksheet, SpaAktion As Long)
ist ein Füchtigkeitsfehler drin.
Sub KopierenAktion(wks_Z As Worksheet, SpaAktion As Long)
Gruß Gerd
AW: Fortlaufend mehrere Zellen markieren/kopieren
23.09.2018 12:01:18
Tobi
Hallo Gerd
Danke jetzt funktioniert es wie gewollt habe auch noch einen weiteren Fehler gefunden.

Dim wksQ As Worksheet
zu
Dim wks_Q As Worksheet

LG Tobi
AW: Fortlaufend mehrere Zellen markieren/kopieren
23.09.2018 13:52:37
Tobi
Hy habe ein weiteres Problem habe es zwar schon irgendwie Lösen können aber zum Rest ist es "Pfusch".
Wollte das in jedem Arbeitsblatt außer dam Hauptblatt(in dass man die Daten einträgt) Rahmen von A1-A10 gesetzt werde, wenn die Liste, die in dem jeweiligen Sheet ist länger als 10 Zeilen misst, müssen die neuen auch eingerahmt werden und Retoure ebenfalls (weniger oder 10 Zeilen belegt nur bis 10 gerahmt)
Hier ist die Datei die ich bearbeite:
https://www.herber.de/bbs/user/124167.xlsm

Danke
LP Tobi
Anzeige
AW: Fortlaufend mehrere Zellen markieren/kopieren
23.09.2018 22:02:56
fcs
Hallo Tobi,
wie beim Übertragen der Daten kann man auch beim Formatieren eine Unter-Routine Schreiben, die für jedes Blatt funktioniert.
Im Hauptmakro werden dann alle Blätter übergeben, die Formatiert werden sollen.
Das kann man hier in einer For-Next-Schleife machen.
Gruß
Franz
'neue Hauptprozedur
Sub Test_Neu_2()
Dim wks As Worksheet
Application.ScreenUpdating = False
With ActiveWorkbook
Call KopierenAktion(wks_Z:=.Worksheets("Essen"), SpaAktion:=6)
Call KopierenAktion(wks_Z:=.Worksheets("Schlafen"), SpaAktion:=7)
Call KopierenAktion(wks_Z:=.Worksheets("Schlüssel"), SpaAktion:=8)
Call KopierenAktion(wks_Z:=.Worksheets("PC"), SpaAktion:=9)
'Linien Formatieren
For Each wks In .Worksheets
Select Case wks.Name
Case "Bearbeiten"
'diese Blätter nicht Formatieren
Case Else
Call Formatieren_Linien(wks)
End Select
Next
End With
Application.ScreenUpdating = True
End Sub
'Makro zum Formatieren der Linien im Tabellenblatt
Sub Formatieren_Linien(wks As Worksheet)
Dim Zeile_L As Long
Dim rngFormat As Range
With wks
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
If Zeile_L 

Anzeige

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige