Spalten und Zeilen unter Bedingungen kopieren

Forumthread: 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

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

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

Beliebteste Forumthreads (12 Monate)

Spalten und Zeilen unter Bedingungen kopieren

Forumthread: Spalten und Zeilen unter Bedingungen kopieren

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Spalten und Zeilen unter Bedingungen kopieren

Forumthread: Spalten und Zeilen unter Bedingungen kopieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread