Gefilterte Datensätze blockweise kopieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Gefilterte Datensätze blockweise kopieren
von: Michael
Geschrieben am: 26.10.2003 19:24:45

Bitte um Hilfe,
ich weiss, dass es ganz einfach geht aber so gut bin ich noch nicht.
Einstweilen mühe ich mich mit umständlichen Eintzelprozeduren mit der Kirche ums Kreuz ab.

Meine Tabelle besteht aus n Zeilen und Spalten A bis G.
In der Spalte G wird immer der Filterbegriff eingegeben.
Die Tabelle wird täglich erweitert und die Filterbegriffe sind variabel.





Danke und einen schönen Sonntag.
Bild


Betrifft: AW: Gefilterte Datensätze blockweise kopieren
von: Lutz
Geschrieben am: 26.10.2003 21:46:56

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


Bild


Betrifft: Eine Variante...
von: Ramses
Geschrieben am: 26.10.2003 22:24:46

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


 Bild

Beiträge aus den Excel-Beispielen zum Thema " Gefilterte Datensätze blockweise kopieren"