PDA

Vollständige Version anzeigen : Gefilterte, sortierte Daten kopieren und in neues Tabellenblatt einfügen


Pluto1
11.07.2014, 12:24
Hallo Zusammen
ERneut ein Frage von mir.
ich habe Daten die mir als csv-Datei geschickt wird. diese muss ich ins Excel
- einlesen,
- Doppelte Datensätze entfernen
- Datensätze älter als aktuelles Datum ausblenden
- in ein weiteres Tabellenblatt (Haupttabelle) kopieren

sind die Daten in der "Haupttabelle" müssen diese Daten gefiltert und sortiert werden.
Die Filterung erfolgt in der Spalte N, wo ein entsprechender Code (1 bis 17) durch einen Index und Vergleich-Funtkion ermittelt wurde, eigentlich muss lediglich #NV nicht berücksichtigt werden.
Danach muss nach Spalte N sortiert werden.

Ist das abgeschlossen, müssen die die Zellen B7:b?, C7:c?,D7:d?, H7:H?, I7:I?, J7:J?, K7:K?, L7:L?sortiert nach dem Code in Spalte N, also alle mit Code 1, separat auf ein neues Blatt kopiert und formatiert werdn, dann der Code 2 usw.

bis und mit sortieren nach dem code in Spalte N funktiniert auch alles aber dann, dass nach dem Code die Daten dann in separate Tabellenblätter kopiert werden, kriege ich nicht hin.
Die Anforderung war früher anders, da konnte ich den Code separat aufrufen lassen und dann diese Filterung in ein separates Tabellenblatt übergeben. Nun möchte man alles mit nur einem "Knopf-Druck" durchführen.

Mein Code:

Sub Alle()


Worksheets("Haupttabelle").Unprotect


'Tabelle6
'wenn kein Autofilter vorhanden, dann in Zeile 7 Autofilter setzen
'wenn Autofilter gesetzt, diesen löschen und alle Daten anzeigen

With Tabelle6
If Not .AutoFilterMode Then .Rows(7).AutoFilter
If .FilterMode Then .ShowAllData

'Code früher
'Zeile 7
'AutoFilter Setzen bei Linie 7, Filter Feld 14, Kriterieum in Zelle C4

'With .Rows(7)
' .AutoFilter Field:=14, Criteria1:=Sheets("Haupttabelle").Range("C4").Value
' End With

'Code neu
'Spalte N filter

ActiveSheet.Range("$A$7:$O$65536").AutoFilter Field:=14, Criteria1:=Array( _
"1", "10", "11", "12", "13", "14", "15", "16", "17", "2", "3", "4", "5", "6", "7", "8", "9"), _
Operator:=xlFilterValues
End With

'Spalte N sortieren

ActiveWorkbook.Worksheets("Haupttabelle").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Haupttabelle").AutoFilter.Sort.SortFields.Add Key _
:=Range("N7:N65536"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Haupttabelle").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
-------------
'Ab hier weiss ich nun nicht, wie ich die übergabe machen soll. Hier sollten nun alle Zeilen mit dem Code 1 in Spalte N kopiert und in ein separates Blatt eingefügt werden, danach Code 2 unsw.

Früher konnte ich wie unten angegeben die Daten in eine neue Tabelle kopieren
-----------

'gefilterte Daten der Spalten B,D,H,I,J,K,L ab Zeile 7 kopieren"

Selection.SpecialCells(xlVisible).Range("b7:b65000,c7:c65000,d7:d65000,h7:H65000,i7:i65000,J7:J65000,K7:K65000,L7:L65000 ").Copy


'neues Tabellenblatt einfügen
'kopierte Daten ab Zelle A5 einfügen

Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Paste Range("A6")


'Tabellenblatt auf A4-Quer einrichten

With ActiveSheet.PageSetup
.Orientation = xlLandscape
.PaperSize = xlPaperA4
.PrintTitleRows = "$6:$6"
.PrintTitleColumns = ""
.TopMargin = Application.InchesToPoints(0.492125984251969)
End With

'Tabellenrahmen über die ganze Tabelle setzen

Range("A6").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
'.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
'.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
'.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
'.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
'.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
'.TintAndShade = 0
.Weight = xlThin
End With


'Spalten A:J automatische Breite
'Spalten A2-H5 Schrift Fett
'Spalte C zentrieren
'Spalten G-H zentrieren

Columns("A:J").EntireColumn.AutoFit
Range("A2:H6").Font.Bold = True
Range("C:C").HorizontalAlignment = xlCenter
Range("G:H").HorizontalAlignment = xlCenter


'Zeile A2-H2 wählen
'Schriftgrösse der gewählten Zeilen 14

Range("A2:H2").Select
Selection.Font.Size = 14

' Text eingeben in Zelle A2
' Text Horizontel ausrichten
' Zellen verbinden

ActiveSheet.Range("A2") = "Überschriftstext"
Range("A2:H2").Select
Selection.HorizontalAlignment = xlCenter
Selection.Merge

Range("A4:H4").Select
Selection.Font.Size = 13
ActiveSheet.Range("A4") = Sheets("Haupttabelle").Range("F4").Value
Selection.HorizontalAlignment = xlCenter ' Text Horizontel ausrichten
Selection.Merge ' Zellen verbinden

ActiveSheet.Name = Sheets("Haupttabelle").Range("D4").Value


'Tabelle6
'wenn kein Autofilter vorhanden, dann in Zeile 7 Autofilter setzen
'wenn Autofilter gesetzt, diesen löschen und alle Daten anzeigen

With Tabelle6
If Not .AutoFilterMode Then .Rows(7).AutoFilter
If .FilterMode Then .ShowAllData
End With

ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftFooter = Sheets("Haupttabelle").Range("D4").Value
.CenterFooter = "&""Calibri,Fett""- VERTRAULICH -"
.RightFooter = "&8&D" & Chr(10) & "Seite &P von &N"

End With

Worksheets("Haupttabelle").Protect 'Tabelle6(Haupttabelle) schützen

End Sub

Leider kann ich die Originaldatei aus Vertraulichkeitsgründen nicht mitschicken.
Weiss trotzdem jemand wie ich das kopieren der gefilterten Daten, gestaffelt nach Code-Nr. kopieren und in separate Blätter übertragen kann?

Danke Gruss Pluto1