Office: VBA mehrere Spalten abfragen, kopieren einfügen

DaveMiller · 6. Februar 2018

Hi zusammen,

mit folgendem code frage ich mehrere sheets ab und eine Spalte (C) und wenn in der Spalte ein X steht kopiert er mir die ganze Zeile und fügt sie mir auf Tabelle1 ein. Jetzt möchte ich das ganze auf mehrere Spalten erweitern.. also es könnte auch sein das in D, E, F ein x steht. es können auch mehrere x in einer Zeile vorkommen. Ich weiß, es gäbe dann doppelte aber die würde ich mit Duplikate entfernen löschen *mrcool

Iwie müsste da eine schleife für die Spalten rein, aber ich hab noch keinen Ansatz...

Danke & Gruß!

Code:

Sub Copy_Paste()
Dim sheet_name As Range
Dim myrange As Range

Application.ScreenUpdating = False

Worksheets("Tabelle1").Range("A2:D5000").Clear

For Each sheet_name In Sheets("Input").Range("A1:A2")
If sheet_name.Value = "" Then
Exit For
Else

Sheets(sheet_name.Value).Select
Set myrange = Sheets(sheet_name.Value).Range("C2", Range("C" & Rows.Count).End(xlUp))
For Each cell In myrange
If (cell.Value) = "x" Then
lr = Sheets("Tabelle1").Range("A" & Rows.Count).End(xlUp).Row
cell.EntireRow.Copy Destination:=Sheets("Tabelle1").Range("A" & lr + 1)
End If
Next cell
End If
Next sheet_name

Worksheets("Tabelle1").Visible = True
Worksheets("Tabelle1").Activate

Application.ScreenUpdating = True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

:)

DaveMiller · 8. Februar 2018

Code:

For i = 3 To 4
Set myrange = Sheets(sheet_name.Value).Range(Cells(2, i), Range(Cells(i) & Rows.Count).End(xlUp))

For Each cell In myrange
If (cell.Value) = "x" Then
lr = Sheets("Tabelle1").Range("A" & Rows.Count).End(xlUp).Row
cell.EntireRow.Copy Destination:=Sheets("Tabelle1").Range("A" & lr + 1)
End If
Next cell
Next i
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Habe es jetzt so versucht, aber da gib er mir immer eine Fehlermeldung *rolleyes.gif*

DaveMiller · 8. Februar 2018

Keiner der mir helfen kann?

rastrans · 8. Februar 2018

Hallo,

also ohne den Code zu testen hätte ich da vielleicht eine Möglichkeit Code:

Set myrange = Sheets(sheet_name.Value).Range("C2:F" & Sheets(sheet_name.Value).UsedRange.Rows.Count)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Du prüfst doch schon mit einer Schleife alle Felder in einem Range. Also erweitere doch den Range!

Das ist aber nur eine
Grüße
rastrans

DaveMiller · 9. Februar 2021

von rastrans

Hallo,

also ohne den Code zu testen hätte ich da vielleicht eine Möglichkeit Code:
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Set myrange = Sheets(sheet_name.Value).Range("C2:F" & Sheets(sheet_name.Value).UsedRange.Rows.Count)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Du prüfst doch schon mit einer Schleife alle Felder in einem Range. Also erweitere doch den Range!

Das ist aber nur eine
Grüße
rastrans

Danke, es geht *Smilie*Smilie

Office: VBA mehrere Spalten abfragen, kopieren einfügen

VBA mehrere Spalten abfragen, kopieren einfügen

VBA mehrere Spalten abfragen, kopieren einfügen

VBA mehrere Spalten abfragen, kopieren einfügen

VBA mehrere Spalten abfragen, kopieren einfügen - Similar Threads - VBA Spalten abfragen

Spalten wieder einblenden per VBA

Wie Spalten per VBA mit definierten Spaltenbreiten einfügen ?

VBA: Spalten auf anderen Worksheeds in der Mappe ausblenden.

Excel VBA Spalten mit Ordnerinhalt vergleichen

VBA - letzte nicht-leere Spalte

Primärschlüssel/Fremdschlüssel aus 2.Tabelle automatisch einfügen

VBA - MS Query --> nur bestimmte Spalten abfragen