Gefilterte Datensätze blockweise kopieren

Forumthread: Gefilterte Datensätze blockweise kopieren

26.10.2003 19:24:45

Michael

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.

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Gefilterte Datensätze blockweise kopieren

26.10.2003 21:46:56

Lutz
Eine Variante...

26.10.2003 22:24:46

Ramses

AW: Gefilterte Datensätze blockweise kopieren

26.10.2003 21:46:56

Lutz

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

Forumthread: Gefilterte Datensätze blockweise kopieren

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

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread