Zeilen verschieben, nach Kriterieum

Hallo zusammen,

ich habe bei mir im Verein, 100terte von Arbeitsplättern in dem unterschiedlichen Equipment erfasst ist. Ich möchte jetzt die Inventur machen und die Altlasten nicht löschen, sondern in eine sep. Tabelle schieben

Jetzt wäre mein Wunsch, dass ich ein Makro hätte oder erstellen kann, was folgendes umsetzt.

Quelle sind die 2 Blätter mit den Namen Übersicht ....
Ziel ist das Blatt mit dem Namen Archiv

Jetzt wäre es gut, wenn, das Makro in das Blatt Archiv geht, dort in Zelle A1 den Wert holt (in dem Fall passiv) und mir alle anderen Arbeitsblätter nach diesem Wert in Spalte C durchsucht.
Wenn er Einträge gefunden hat, soll er mir bitte die jeweilige Zeile ausschneiden und in dem Arbeitsblatt Archiv unten anfügen.

Ist das möglich? Wenn wie, bzw. nach welchen Punkten muss ich suchen?

Es soll danach keine Zeile doppelt vorhanden sein.

Bsp anbei

Danke im Voraus
Marcus

https://www.herber.de/bbs/user/159208.xlsm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo zusammen,

der Code funktioniert super, nur kann er mit Automatischer Tabelle umgehen, da er ja den Autofilter stetzt und entfernt.

Kann da jemand helfen?

Sub versuch()
Dim letzte As Long
Dim letzte2 As Long
Dim zelle As Range
Dim wksQ As Worksheet
Dim wksZ As Worksheet
  Set wksQ = Worksheets("aktuelle Projekte")
   Set wksZ = Worksheets("abgeschlossene Projekte")
   With wksQ
        letzte = .Cells(.Rows.Count, 1).End(xlUp).Row
        letzte2 = wksZ.Cells(wksZ.Rows.Count, 1).End(xlUp).Row + 1
    If Application.CountIf(.Columns(8), 100) = 0 Then Exit Sub ' wenn keine 100 dann Code beenden
    Application.ScreenUpdating = False 'Bildschirmaktuellisierung aus
         .Columns(8).AutoFilter Field:=1, Criteria1:=100
          .Range("A2:K" & letzte).SpecialCells(xlCellTypeVisible).Copy
   wksZ.Range("A" & letzte2).PasteSpecial Paste:=xlValues
      For Each zelle In .Range("A2:K" & letzte).SpecialCells(xlCellTypeVisible)
        If Not zelle.HasFormula Then zelle.ClearContents
      Next
      .Columns(8).AutoFilter
   End With
   Set wksQ = Nothing
   Set wksZ = Nothing
Application.ScreenUpdating = True 'Bildschirmaktuellisierung ein
End Sub

Sub Unit() Dim strKrit As String, strErste As String, rngAlt As Range, rngLoesch As Range strKrit = ThisWorkbook.Worksheets("Archiv").Cells(1, 1) For Each WS In ThisWorkbook.Worksheets If WS.Name > "Archiv" Then Set rngAlt = WS.Columns(3).Find(strKrit, lookat:=xlWhole, LookIn:=xlValues, MatchCase:=False) If Not rngAlt Is Nothing Then strErste = rngAlt.Address Do If Not rngLoesch Is Nothing Then Set rngLoesch = Union(rngLoesch, rngAlt) Else: Set rngLoesch = rngAlt End If rngAlt.EntireRow.Copy Destination:=Sheets("Archiv").Cells(Rows.Count, 1).End(xlUp).Offset(1) Set rngAlt = WS.Columns(3).FindNext(after:=rngAlt) Loop Until rngAlt.Address = strErste End If If Not rngLoesch Is Nothing Then rngLoesch.EntireRow.Delete Set rngLoesch = Nothing Set rngAlt = Nothing End If Next End Sub

Beliebteste Forumthreads (12 Monate)

Zeilen verschieben, nach Kriterieum

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread