Microsoft Office Forum [ www.Office-Fragen.de ] >> READONLY <<

Hallo Zusammen  ,

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:

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:

"What:="*"
welches ich durch eine Art:

If .Cells(Zeile, 1).Value = "X" Then
ersetzen müsste. Jedoch weiß ich leider nicht wie. 


Gruß

Muzel


PS:

Begonnen hatte ich mit:

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.