Suche+ausschneiden in Spalte B

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Suche_ausschneiden() Dim lz, lr, i As Integer Dim sh1, sh2 As Worksheet Set sh1 = Sheets("Tabelle1") 'Quelle Set sh2 = Sheets("Tabelle2") 'Ziel lz = sh1.Cells(Rows.Count, 2).End(xlUp).Row ' letzte Zeile For i = lz To 1 Step -1 If sh1.Cells(i, 2) = "5n" Then lr = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' freie Zeile sh1.Rows(i).Copy sh2.Cells(lr, 1) sh1.Rows(i).Delete Shift:=xlUp End If Next i End Sub

Private Sub cmd5n_Click() Dim lngReihen As Long lngReihen = ActiveSheet.UsedRange.Rows.Count Selection.AutoFilter Field:=2, Criteria1:="=5n" Application.ScreenUpdating = False Rows("2:" & lngReihen).Select Selection.Copy Sheets("Neues Sheet").Activate Sheets("Neuses Sheet").Range("A2").Activate Sheets("Neuses Sheet").Paste Application.CutCopyMode = False Application.ScreenUpdating = True End Sub

Hallo S.,
hier noch ein Code. Der sollte, vor allem bei großen Listen, schneller sein.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Cut_5n_NewSheet()
Dim rng As Range, rngC As Range
Dim strFirst As String
Dim objNewSheet As Worksheet, objSh As Worksheet

On Error GoTo ErrExit
GMS

Set objSh = ThisWorkbook.Sheets("Tabelle1") 'Name der Tabelle in der gesucht wird - anpassen!

Set rng = objSh.Columns(2).Find(What:="5n", LookAt:=xlWhole, after:=objSh.Range("B1"))

If Not rng Is Nothing Then

    strFirst = rng.Address

    Do

        If rngC Is Nothing Then
            Set rngC = rng.EntireRow
        Else
            Set rngC = Union(rngC, rng.EntireRow)
        End If

        Set rng = objSh.Columns.FindNext(rng)

    Loop While Not rng Is Nothing And rng.Address <> strFirst

End If

If Not rngC Is Nothing Then

    Set objNewSheet = ThisWorkbook.Worksheets.Add(after:=objSh)

    objNewSheet.Name = "Export_" & Format(Now, "ddmmyy_hhmmss")

    objSh.Rows(1).Copy objNewSheet.Range("A1")
    rngC.Copy objNewSheet.Range("A2")
    rngC.Delete
End If

ErrExit:
GMS True
Set rng = Nothing
Set rngC = Nothing
Set objSh = Nothing
Set objNewSheet = Nothing
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    .Calculation = IIf(Modus, -4105, -4135)
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread