Gefilterte Datensätze blockweise kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Micha,

wenn es bei 3 Filterkriterien bleibt, könnte es so funktionieren:

Sub Sort1()
Cells.Copy
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Date
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Key2:=Range("D2") _
    , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
    False, Orientation:=xlTopToBottom
Rows("1:1").Insert Shift:=xlDown
[A1] = [G3]
gRow = [G65536].End(xlUp).Row
For i = 3 To gRow + 7
    If Range("G" & i).Value = Range("G" & i + 1).Value Then
        i = i + 1
    Else
        Rows(i + 1 & ":" & i + 3).Select
        Selection.Insert Shift:=xlDown
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        Rows(2).Copy
        Rows(i + 3).Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Range("A" & i + 2).Value = Range("G" & i + 4).Value
        i = i + 4
    End If
Next i
End Sub

Code eingefügt mit Syntaxhighlighter 2.1

Gruß Lutz

Hallo,

probier mal das.
Ist nicht limitiert und tut eigentlich was es soll :-)

Option Explicit

Sub Sort_and_BuiltUp_Filterblocks()
'by Ramses
'Variablendeklaration
Dim i As Integer
Dim DbR As Integer, DbC As Integer, Cr As Long, Cc As Integer
Dim wks1 As Worksheet, wks2 As Worksheet
Dim CheckName As String
Dim CopyHeader As Range
'Variablen setzen
'Datentabelle
Set wks1 = Worksheets("Tabelle1")
'Sortier und Ausgabetabelle
Set wks2 = Worksheets("Tabelle2")
'Trennzeile definieren
Set CopyHeader = wks1.Range("A1:G1")
'Bildschirmaktualisierung ausschalten
'-
'Application.ScreenUpdating = False
'-
'Zieltabelle Inhalte löschen
'und Formate löschen
With wks2.Cells
    .Clear
    .Interior.ColorIndex = xlNone
    .Font.ColorIndex = 0
End With
'Datenbereich kopieren
wks1.Activate
DbR = 1
DbC = wks1.Cells(65536, 7).End(xlUp).Row
wks1.Range(Cells(DbR, 1), Cells(DbC, 7)).Copy Destination:=wks2.Cells(1, 1)
'Datenbereich sortieren
wks2.Activate
wks2.Range("A1").Select
wks2.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
CheckName = wks2.Cells(2, 7).Value
wks2.Range(Cells(1, 1), Cells(1, 7)).Insert shift:=xlDown
wks2.Cells(1, 1).Value = CheckName
'Datenblöcke bilden
Cr = 4
Do While wks2.Cells(Cr, 7) <> ""
    If wks2.Cells(Cr, 7).Value <> CheckName Then
        wks2.Range(Cells(Cr, 1), Cells(Cr + 2, 7)).Insert shift:=xlDown
        Cr = Cr + 3
        wks2.Cells(Cr - 2, 1).Value = wks2.Cells(Cr, 7).Value
        CopyHeader.Copy Destination:=wks2.Cells(Cr - 1, 1)
        CheckName = wks2.Cells(Cr, 7).Value
        Debug.Print CheckName & " " & Cr
    Else
        Cr = Cr + 1
    End If
Loop
'Bildschirmaktualisierung einschalten
Application.ScreenUpdating = True
MsgBox "Datenübertrag und Sortierung abgeschlossen"
End Sub

Code eingefügt mit Syntaxhighlighter 1.16

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

Gefilterte Datensätze blockweise kopieren

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Gefilterte Datensätze blockweise kopieren

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread