14.02.2017, 11:19
Hallo zusammen,
bei mir kommt öfters die gleiche Arbeit rein, dann dachte ich mir mit einem Makro könnte das mit einem klick gehen.
Soweit so gut funktioniert auch alles, nur wenn die Listen größer werden weis ich nicht ob das dann immer noch so klappt.
Habe eine Marko Aufzeichnung gemacht, und erkläre kurz was die Arbeitsschritte sind, denn das Makro kann man bestimmt auch kürzer machen.
Also:
1. Alle Zellen markieren -> "Zeilenumbruch" und "Zellen verbinden" deaktivieren.
2. Zeile 2-4 löschen.
3. Zelle A1 ausschneiden und in F1 einfügen.
4. Spalten A - AA Filter aktivieren.
5. Spalte E nach leeren Zellen filtern, und alle bis zum letzten Eintrag löschen, danach wieder alles einblenden.
6. Spalte A - D löschen.
7. Nun Spalte D - R löschen. (Durch Punkt 6 wurde Spalte E F und G zu A B C)
8. Spalte E - I löschen.
9. Spalte A - D Duplikate entfernen wenn A, B, C und D identisch sind mit einer anderen Zeile.
10. Nun Spalte A - D Sortieren nach:
Ebene 1 = Spalte D Werte A-Z
Ebene 2 = Spalte B Werte A-Z
11. Spalte C mit Spalte D tauschen (ich mache das immer mit ausschneiden.)
Dann bleiben mir immer noch X tausend Leere Zeilen unten stehen, wenn man diese noch weg bekommen könnte wäre echt super !!!!!
Anbei die Makro Aufzeichnung:
Wäre echt klasse wenn das irgendwie gehen könnte mit dass das dann für jede Liste geht, egal wie lang sie ist.
Vielen vielen dank für die Bemühungen!!!!
bei mir kommt öfters die gleiche Arbeit rein, dann dachte ich mir mit einem Makro könnte das mit einem klick gehen.
Soweit so gut funktioniert auch alles, nur wenn die Listen größer werden weis ich nicht ob das dann immer noch so klappt.
Habe eine Marko Aufzeichnung gemacht, und erkläre kurz was die Arbeitsschritte sind, denn das Makro kann man bestimmt auch kürzer machen.
Also:
1. Alle Zellen markieren -> "Zeilenumbruch" und "Zellen verbinden" deaktivieren.
2. Zeile 2-4 löschen.
3. Zelle A1 ausschneiden und in F1 einfügen.
4. Spalten A - AA Filter aktivieren.
5. Spalte E nach leeren Zellen filtern, und alle bis zum letzten Eintrag löschen, danach wieder alles einblenden.
6. Spalte A - D löschen.
7. Nun Spalte D - R löschen. (Durch Punkt 6 wurde Spalte E F und G zu A B C)
8. Spalte E - I löschen.
9. Spalte A - D Duplikate entfernen wenn A, B, C und D identisch sind mit einer anderen Zeile.
10. Nun Spalte A - D Sortieren nach:
Ebene 1 = Spalte D Werte A-Z
Ebene 2 = Spalte B Werte A-Z
11. Spalte C mit Spalte D tauschen (ich mache das immer mit ausschneiden.)
Dann bleiben mir immer noch X tausend Leere Zeilen unten stehen, wenn man diese noch weg bekommen könnte wäre echt super !!!!!
Anbei die Makro Aufzeichnung:
Code:
Sub Artikel()
Cells.Select
With Selection
.WrapText = False
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("2:4").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Selection.Cut
Range("F1").Select
ActiveSheet.Paste
Columns("A:AA").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AA$6736").AutoFilter Field:=5, Criteria1:="="
Rows("3:20000").Select
Selection.Delete Shift:=xlUp
ActiveSheet.Range("$A$1:$AA$4695").AutoFilter Field:=5
Columns("A:D").Select
Selection.Delete Shift:=xlToLeft
Columns("D:R").Select
Selection.Delete Shift:=xlToLeft
Columns("E:J").Select
Selection.Delete Shift:=xlToLeft
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A2:D2").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.SmallScroll Down:=-51
ActiveSheet.Range("$A$2:$D$4695").RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
Header:=xlYes
ActiveWorkbook.Worksheets("P160263").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("P160263").Sort.SortFields.Add Key:=Range( _
"D3:D4695"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("P160263").Sort.SortFields.Add Key:=Range( _
"B3:B4695"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("P160263").Sort
.SetRange Range("A2:D4695")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("C:C").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
End Sub
Wäre echt klasse wenn das irgendwie gehen könnte mit dass das dann für jede Liste geht, egal wie lang sie ist.
Vielen vielen dank für die Bemühungen!!!!