Spalten und Zeilen unter Bedingungen kopieren

25.11.2019 16:23:04

Christian

Hallo zusammen,
ich habe bestimmte Spalten und Zeilen in einem Tabellenblatt mit "X" gekennzeichnet und möchte nur diese Spalten und Zeilen in ein neues Tabellenblatt kopieren. Mir fehlt gerade die zündende Idee. Mit Zeilen habe ich das schon mal geschafft, aber mit Spalten nicht und beides gleichzeitig sowieso leider nicht. Hat jemand eine VBA Code Idee?
LG und vielen Dank Christian

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Spalten und Zeilen unter Bedingungen kopieren

25.11.2019 23:16:44

Werner
AW: Spalten und Zeilen unter Bedingungen kopieren

26.11.2019 09:05:58

Christian
AW: Spalten und Zeilen unter Bedingungen kopieren

01.12.2019 10:23:32

Werner
nimm lieber den Code

01.12.2019 11:28:42

Werner

AW: Spalten und Zeilen unter Bedingungen kopieren

25.11.2019 23:16:44

Werner

Hallo Christian,
mit den Angaben erwartest du nicht ernsthaft Hilfe?
bestimmte Spalten Excel hat über 16000 davon
bestimmte Zeilen Excel hat über 1000000 davon
Und selbst wenn man wüsste um welche Zeilen/Spalten es geht, dann weiß man immer noch nicht wo die Zeilen bzw. Spalten mit x markiert sind.
Was häslt du von einer Beispielmappe?
Gruß Werner

AW: Spalten und Zeilen unter Bedingungen kopieren

26.11.2019 09:05:58

Christian

Hallo Werner,
Du hast Recht. Anbei eine Beispieldatei. Es geht darum, in Zeile 1 zu schauen, wo Zellen gefüllt sind (bis AZ oder so, kann fest definiert werden) und diese Spalte dann in ein anderes Blatt kopieren und zwar alle Daten, die in Spalte A ein "X" haben. Ich hoffe, es ist nun klarer :)
Datei:
https://www.herber.de/bbs/user/133438.xlsx

AW: Spalten und Zeilen unter Bedingungen kopieren

01.12.2019 10:23:32

Werner

Hallo Christian,
teste mal:

Public Sub Kopieren()
Dim loLetzte As Long, loSpalte As Long, i As Long
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
If WorksheetFunction.CountIf(.Columns("A"), "X") > 0 Then
loLetzte = .Cells(.Rows.Count, "A").End(xlUp).Row
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 1), .Cells(1, loSpalte)).Copy Worksheets("Tabelle2").Range("A1")
.Range(.Cells(10, "A"), .Cells(loLetzte, loSpalte)).AutoFilter field:=1, Criteria1:="X"
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
With Worksheets("Tabelle2")
.Range("A" & .Cells(.Rows.Count, loSpalte).End(xlUp).Offset(1).Row). _
PasteSpecial _
Paste:=xlPasteAll
For i = loSpalte To 1 Step -1
If Len(.Cells(1, i)) = 0 Then
.Columns(i).Delete
End If
Next i
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, "A"), .Cells(1, loSpalte)).EntireColumn.AutoFit
End With
End With
Else
MsgBox "Es sind keine Datensätze markiert."
End If
If .AutoFilterMode Then .Rows(10).AutoFilter
End With
End Sub

Gruß Werner

nimm lieber den Code

01.12.2019 11:28:42

Werner

Hallo,
anscheinend hast du in deiner Zeile 1 irgendwelche versteckte Steuerzeichen

Public Sub Kopieren()
Dim loLetzte As Long, loSpalte As Long, i As Long
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
If WorksheetFunction.CountIf(.Columns("A"), "X") > 0 Then
loLetzte = .Cells(.Rows.Count, "A").End(xlUp).Row
On Error Resume Next
On Error GoTo Ausgang
loSpalte = .Rows("1:1").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, _
searchdirection:=xlPrevious).Column
.Range(.Cells(1, 1), .Cells(1, loSpalte)).Copy Worksheets("Tabelle2").Range("A1")
.Range(.Cells(10, "A"), .Cells(loLetzte, loSpalte)).AutoFilter field:=1, Criteria1:="X"
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
With Worksheets("Tabelle2")
.Range("A" & .Cells(.Rows.Count, loSpalte).End(xlUp).Offset(1).Row). _
PasteSpecial Paste:=xlPasteAll
For i = loSpalte To 1 Step -1
If Len(.Cells(1, i)) = 0 Then
.Columns(i).Delete
End If
Next i
loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, "A"), .Cells(1, loSpalte)).EntireColumn.AutoFit
End With
End With
Else
MsgBox "Es sind keine Datensätze markiert."
End If
If .AutoFilterMode Then .Rows(10).AutoFilter
Exit Sub
End With
Ausgang:
MsgBox "Es gibt keine Überschriften in Zeile 1."
On Error GoTo -1
End Sub

Gruß Werner