kopieren in das letzte Tabellenblatt

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Option Explicit Sub Overview() Dim wks As Worksheet Dim i&, k& k = 4 With Sheets("Übersicht") .Rows(5).Resize(.Rows.Count - 4).Delete For Each wks In ThisWorkbook.Worksheets If wks.Name "Übersicht" Then For i = 5 To wks.Cells(wks.Rows.Count, 1).End(xlUp).Row If wks.Cells(i, 1) = "X" Then k = k + 1 wks.Rows(i).Copy .Cells(k, 1) End If Next End If Next End With End Sub

Hallo Marco,
probier mal.

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Uebersicht()
  Dim objSh As Worksheet, objTarget As Worksheet
  Dim rng As Range, lngRow As Long
  Dim strFirst As String

  Set objTarget = Sheets("Übersicht")

  With objTarget
    .Range("A5:A" & .Rows.Count).EntireRow.Clear
    lngRow = 5
    For Each objSh In ThisWorkbook.Worksheets
      If Not objSh Is objTarget Then
        strFirst = ""
        Set rng = objSh.Range("A:A").Find(What:="X", LookIn:=xlValues, _
          LookAt:=xlWhole, MatchCase:=False, SearchDirection:=xlNext, After:=objSh.Range("A5"))

        If Not rng Is Nothing Then
          strFirst = rng.Address
          Do
            rng.EntireRow.Copy .Cells(lngRow, 1)
            lngRow = lngRow + 1
            Set rng = objSh.Range("A:A").FindNext(rng)
          Loop While Not rng Is Nothing And strFirst <> rng.Address
        End If
      End If
    Next
  End With

  Set rng = Nothing
  Set objSh = Nothing
  Set objTarget = Nothing
End Sub

Gruß Sepp

Hallo Marco,
kein Problem.

Sub Uebersicht()
  Dim objSh As Worksheet, objTarget As Worksheet
  Dim rng As Range, lngRow As Long
  Dim strFirst As String

  Set objTarget = Sheets("Übersicht")

  With objTarget
    .Range("A5:A" & .Rows.Count).EntireRow.Clear
    lngRow = 5
    For Each objSh In ThisWorkbook.Worksheets
      If Not objSh Is objTarget Then
        strFirst = ""
        Set rng = objSh.Range("A:A").Find(What:="X", LookIn:=xlValues, _
          LookAt:=xlWhole, MatchCase:=False, SearchDirection:=xlNext, After:=objSh.Range("A5"))

        If Not rng Is Nothing Then
          strFirst = rng.Address
          Do
            rng.EntireRow.Copy
            .Cells(lngRow, 1).PasteSpecial xlValues
            .Cells(lngRow, 1).PasteSpecial xlFormats
            lngRow = lngRow + 1
            Set rng = objSh.Range("A:A").FindNext(rng)
          Loop While Not rng Is Nothing And strFirst <> rng.Address
        End If
      End If
    Next
  End With
  Application.CutCopyMode = False
  Set rng = Nothing
  Set objSh = Nothing
  Set objTarget = Nothing
End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

kopieren in das letzte Tabellenblatt

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

kopieren in das letzte Tabellenblatt

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread