[VBA] Zeilen unter Voraussetzung kopieren

[Ultrafear]

Hallo Zusammen  [Bild: cheesy.gif],

ich habe folgendes Problem:
Ich möchte gern über eine Schaltfläche alle Zeilen von Tabellenblatt1 auf Tabellenblatt2 kopieren wo in Spalte A ein "X" steht. Wird die Schaltfläche ein weiteres Mal betätigt, soll die gleiche Aktion erneut ausgeführt werden. Jedoch diesmal alle Werte darunter platziert werden.

Ich habe schon einiges an Code mir zusammenstückeln können:

Code:

Sub NurMitInhaltKopieren()
'Nur Zellen mit "X" in Spalte A auf anderes Blatt kopieren
  Dim lRowSrc As Long, fFreeDst As Long
  Dim lColSrc As Integer
  Dim wksSrc As Worksheet, wksDst As Worksheet
  Dim ZeSrc As Long, ZeDst As Long
  Dim rngZe As Range
     
  With ActiveWorkbook
     Set wksSrc = .Sheets("Tabelle1")
     Set wksDst = .Sheets("Tabelle2")
  End With
  With wksSrc
     lRowSrc = .Cells.Find(What:="*", SearchOrder:=xlByRows, _
      SearchDirection:=xlPrevious).Row
     lColSrc = .Cells.Find(What:="*", SearchOrder:=xlByColumns, _
      SearchDirection:=xlPrevious).Column
  End With
  With wksDst
     If WorksheetFunction.CountA(.Cells) = 0 Then
        fFreeDst = 1
     Else
        fFreeDst = .Cells.Find(What:="*", SearchOrder:=xlByRows, _
         SearchDirection:=xlPrevious).Row + 1
     End If
  End With
  On Error GoTo ErrorHandler
  With wksSrc
     For ZeSrc = 1 To lRowSrc
        Set rngZe = .Range(.Cells(ZeSrc, 1), .Cells(ZeSrc, lColSrc))
        If WorksheetFunction.CountA(rngZe) > 0 Then
           rngZe.Copy wksDst.Cells(fFreeDst, 1)
           fFreeDst = fFreeDst + 1
        End If
     Next ZeSrc
  End With
ErrorHandler:
  If Err.Number <> 0 Then
     MsgBox "Fehler Nummer: " & Err.Number & vbCrLf _
      & "Fehler: " & Err.Description
  End If
End Sub

Jetzt habe ich das Problem, dass alle Zellen mit Inhalt kopiert werden und es nicht auf Spalte A "X" limitiert ist.


Könnte mir vielleicht einer von Euch erklären wie ich das ganze umzusetzen habe? Ich glaube es liegt am:

Code:

"What:="*"

welches ich durch eine Art:

Code:

If .Cells(Zeile, 1).Value = "X" Then

ersetzen müsste. Jedoch weiß ich leider nicht wie.  





Gruß



Muzel





PS:


Begonnen hatte ich mit:

Code:

Sub Copy()

Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long

With Tabelle1
ZeileMax = .UsedRange.Rows.Count
n = 1

For Zeile = 2 To ZeileMax

If .Cells(Zeile, 1).Value = "X" Then

.Rows(Zeile).Copy Destination:=Tabelle2.Rows(n)
n = n + 1

End If
Next Zeile
End With

End Sub

Jedoch fehlte hier die Funktionalität nur die Werte zu kopieren und diese untereinender einzufügen.

[1Matthias]

Moin! Also habe mich mal nur deinem ersten Versuch angenommen und dort noch ergänzt, dass der der Eintrag im Blatt 2 auch immer dynamisch nach unten wandert. VG

Code:

Sub Copy()

Dim Zeile As Long
Dim ZeileMax As Long
Dim zielzeile As Long


With Tabelle1
ZeileMax = .UsedRange.Rows.Count


zielzeile = Tabelle2.Cells(Tabelle2.Rows.Count, 1).End(xlUp).Row + 1
For Zeile = 2 To ZeileMax

If .Cells(Zeile, 1).Value = "X" Then

.Rows(Zeile).Copy Destination:=Tabelle2.Rows(zielzeile)
zielzeile = zielzeile + 1


End If
Next Zeile
End With

End Sub