Herbers Excel-Forum - das Archiv
Gefilterte Datensätze blockweise kopieren
- Gefilterte Datensätze blockweise kopieren von Michael vom 26.10.2003 19:24:45
- AW: Gefilterte Datensätze blockweise kopieren - von Lutz am 26.10.2003 21:46:56
- Eine Variante... - von Ramses am 26.10.2003 22:24:46
- AW: Gefilterte Datensätze blockweise kopieren - von Lutz am 26.10.2003 21:46:56
 |
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.
 |
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
|
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 :-)
Code eingefügt mit Syntaxhighlighter 1.16
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
Gruss Rainer
| |