VBA Aufzeichnung kürzen

[Luffy]

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:

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!!!!

[Gast 123]

Hallo Luffy

probier es bitte einmal in einer Testdatei mit meiner gekürzten Version. Sie ist aber nicht getestet!! 

mfg  Gast 123

Code:

Option Explicit      '14.2.2017  Gast 123  Clever Forum



Sub Artikel()
Dim lz As Long  'LastZell

' 1. Alle Zellen markieren -> "Zeilenumbruch" und  "Zellen verbinden" deaktivieren.
  With Cells
      .WrapText = False
      .AddIndent = False
      .MergeCells = False
  End With
 
' 2. Zeile 2-4 löschen.
  Rows("2:4").Delete Shift:=xlUp
' 3. Zelle A1 ausschneiden und in F1 einfügen.
  Range("A1").Cut Range("F1")
  Application.CutCopyMode = False
 
' 4. Spalten A - AA Filter aktivieren.
  Columns("A:AA").AutoFilter
' 5. Spalte E nach leeren Zellen filtern, und alle bis zum letzten Eintrag löschen, danach wieder alles einblenden.
  ActiveSheet.Range("$A$1:$AA$" & lz).AutoFilter Field:=5, Criteria1:="="
  Rows("3:20000").Delete Shift:=xlUp
  ActiveSheet.Range("$A$1:$AA$" & lz).AutoFilter Field:=5
 
' 6. Spalte A - D löschen.
  Columns("A:D").Delete Shift:=xlToLeft
' 7. Nun Spalte D - R löschen. (Durch Punkt 6 wurde Spalte E F und G zu A B C)
  Columns("D:R").Delete Shift:=xlToLeft
' 8. Spalte E - I löschen.
  Columns("E:J").Delete Shift:=xlToLeft
 
' 9. Spalte A - D Duplikate entfernen wenn A, B, C und D identisch sind mit einer anderen Zeile.
  ActiveSheet.Range("$A$2:$D$" & lz).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
 
' 10. Nun Spalte A - D Sortieren nach:
  lz = ActiveWorkbook.Worksheets("P160263").UsedRange.Rows.Count
  ActiveWorkbook.Worksheets("P160263").Sort.SortFields.Clear
'     Ebene 1 = Spalte D Werte A-Z
  ActiveWorkbook.Worksheets("P160263").Sort.SortFields.Add Key:=Range( _
      "D3:D" & lz), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'     Ebene 2 = Spalte B Werte A-Z
  ActiveWorkbook.Worksheets("P160263").Sort.SortFields.Add Key:=Range( _
      "B3:B" & lz), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With ActiveWorkbook.Worksheets("P160263").Sort
      .SetRange Range("A2:D" & lz)
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With
 
' 11. Spalte C mit Spalte D tauschen (ich mache das immer mit ausschneiden.)
  Columns("C:C").Cut
  Columns("E:E").Insert Shift:=xlToRight
  Application.CutCopyMode = False
End Sub

[Luffy]

Hallo Gast123,

Vielen dank schon mal für deine Bemühungen.
Das Makro funktioniert bis zu Punkt 4, ab Punkt 5 kommt leider ein Error. 
(Laufzeitfehler '1004' Anwendungs- oder objektdefinierte fehler)
Habe nun eine Beispieldatei + Musterlösung erstellt, hier nochmal die einzelenen Arbeitsschritte:

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 !!!!!

hier ist die Datei :


  Test Datei.xlsx (Größe: 16,27 KB / Downloads: 6)

Hoffe es kann jemand helfen, wäre echt klasse !!

[Gast 123]

Hallo Luffy

anbei deine Test Datei mit korrigiertem Makro zurück. Im Modul1 musst du bitte noch den Namen der Tabelle angeben, in der das Makro auch laufen soll. Bei mir habe ich zur Demo die neue Tabelle "Ergebnis" genommen.  Im Makro siehst du den ersten Teil in: ********* Zeichen gesetzt.  D.h., diesen Teil brauchst du nur, wenn du die Daten aus einer anderen Datei kopieren willst.  Sonst kannst du den in **** gesetzten Teil komplett löschen!!

Beim ersten Makro ging ich irrtümlich von zwei Tabellen aus, deshalb klappte es nicht. Den Fehler habe ich korrigiert.

mfg  Gast 123

[Luffy]

Hallo Gast123,

wow klappt schon (fast)perfekt. :)

Noch 2 Dinge (nur wenn sie machbar sind).

1. Wenn ich den ****** aus kommentiere und das Makro starte, bleiben noch ganz viele leere Zeilen im Dokument übrig, kann man die noch automatisch löschen lassen ?
2. Das mit dem kopieren ist echt eine Klasse Idee, nur haben diese Listen die ich bekomme immer einen Separaten Namen als "Tabellenblatt" 

Kann man in:

Code:

Worksheets("Test").UsedRange.Copy

aus dem ("Test") eine Funktion zum Auslesen des Tabellenblatt-namens machen ? 

Ich weis nicht ob diese Sachen verwirklichbar sind, ich spekuliere nur herum :D

Aber so wie es ist ist es wie gesagt schon extrem Hilfreich. Vielen vielen Dank !!!!  :15:

[Gast 123]

Hallo Luffy,

ich habe den Code am Anfang um eine InputBox erweitert, und am Ende um überflüssige Leerzeilen löschen erweitert.
Ich hoffe das ich die Sache mit den Leerzeilen richtig verstanden habe, sonst den Teil besser weglassen.

mfg Gast 123

Code:

Sub Artikel()
Dim Egb As Variant, lz As Long   'LastZell
Worksheets("Ergebnis").Select   'hier bitte Aktive Tabelle angeben !!

 'Tabelle Name zum Kopieren über InputBox einlesen
 Egb = InputBox("Bitte Tabelle zum kopieren angeben")
 If Egb = Empty Then Exit Sub

 On Error Resume Next
 lz = Worksheets(Egb).Cells.Rows.Count  '** nur zur Fehlerprüfung!!
 If Err > 0 Then MsgBox "Diese Tabelle existiert nicht!!": Exit Sub

'************************************************************
'diesen Teil nur wenn die Daten vorher kopiert werden sollen
 Worksheets(Egb).UsedRange.Copy
 Worksheets("Ergebnis").Range("A1").PasteSpecial xlPasteAll
 Application.CutCopyMode = False
'************************************************************

xxxxxxxx Code:  
' 11. Spalte C mit Spalte D tauschen (ich mache das immer mit ausschneiden.)
 Columns("C:C").Cut
 Columns("E:E").Insert Shift:=xlToRight
 Application.CutCopyMode = False

'**  neu eingefügt:
 'letzte Leerzeilen emitteln
 lz = Range("A2").End(xlDown).Row + 1
 Egb = ActiveSheet.UsedRange.Rows.Count
 'überflüssige Leerzeilen löschen
 If Egb > lz Then Rows(lz & ":" & Egb).Delete Shift:=xlUp
End Sub

[atilla]

Hallo zusammen,

nur ein Tipp am Rande:

Statt den Autofilter zu bemühen, könnte es vielleicht schneller gehen, wenn man über: Suchen und auswählen -> Inhalte auswählen -> Leerzellen , nutzt.
Natürlich als Code (SpecialCells). Wenn keine Leerzellen vorhanden sind kann es zum fehler kommen und muss im Code abgefangen werden.

[Luffy]

Hallo,

jetzt passt alles :)

Habe den Code noch ein bisschen erweitert, dass es das Tabellenblatt mit den Rohdaten und das Tabellenblatt mit den Ergebnis ausließt (Bzw wo das Ergebnis dann hin kommt).

Vielen dank für die großartige Hilfe. :)

Anbei der aktuell funktionierende Code (Habe den letzten Teil so gemacht wie Atilla das beschrieben hat):

Code:

Sub Artikel()

Dim Egb As Variant, lz As Long  'LastZell


'Ergebnis-Tabellenblatt angeben
Egb = InputBox("Ergebnis-Tabellenblatt angeben")
If Egb = Empty Then Exit Sub

On Error Resume Next
lz = Worksheets(Egb).Cells.Rows.Count  '** nur zur Fehlerprüfung!!
If Err > 0 Then MsgBox "Diese Tabelle existiert nicht!!": Exit Sub
 
'Rohdaten Tabelle angeben
AGB = InputBox("Rohdaten Tabellenblatt angeben")
If AGB = Empty Then Exit Sub

On Error Resume Next
lz = Worksheets(AGB).Cells.Rows.Count  '** nur zur Fehlerprüfung!!
If Err > 0 Then MsgBox "Diese Tabelle existiert nicht!!": Exit Sub

Worksheets(Egb).Select   'hier bitte Aktive Tabelle angeben !!

 '************************************************************
 'diesen Teil nur wenn die Daten vorher kopiert werden sollen
  Worksheets(AGB).UsedRange.Copy
  Worksheets(Egb).Range("A1").PasteSpecial xlPasteAll
  Application.CutCopyMode = False
 '************************************************************
 

' 1. Alle Zellen markieren -> "Zeilenumbruch" und  "Zellen verbinden" deaktivieren.
  With Cells
      .WrapText = False
      .MergeCells = False
  End With
 
' 2. Zeile 2-4 löschen.
  Rows("2:4").Delete Shift:=xlUp
  lz = ActiveSheet.UsedRange.Rows.Count
' 3. Zelle A1 ausschneiden und in F1 einfügen.
  Range("A1").Cut Range("F1")
  Application.CutCopyMode = False

' 4. Spalten A - AA Filter aktivieren.
  Columns("A:AA").AutoFilter
' 5. Spalte E nach leeren Zellen filtern, und alle bis zum letzten Eintrag löschen, danach wieder alles einblenden.
  Range("$A$1:$AA$" & lz).AutoFilter Field:=5, Criteria1:="="
  Rows("3:20000").Delete Shift:=xlUp
  Range("$A$1:$AA$" & lz).AutoFilter Field:=5
 
' 6. Spalte A - D löschen.
  Columns("A:D").Delete Shift:=xlToLeft
' 7. Nun Spalte D - R löschen. (Durch Punkt 6 wurde Spalte E F und G zu A B C)
  Columns("D:R").Delete Shift:=xlToLeft
' 8. Spalte E - I löschen.
  Columns("E:J").Delete Shift:=xlToLeft
 
' 9. Spalte A - D Duplikate entfernen wenn A, B, C und D identisch sind mit einer anderen Zeile.
  Range("$A$2:$D$" & lz).RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
 
' 10. Nun Spalte A - D Sortieren nach:
  lz = ActiveSheet.UsedRange.Rows.Count
  ActiveSheet.Sort.SortFields.Clear
'     Ebene 1 = Spalte D Werte A-Z
  ActiveSheet.Sort.SortFields.Add Key:=Range("D3:D" & lz), _
     SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'     Ebene 2 = Spalte B Werte A-Z
  ActiveSheet.Sort.SortFields.Add Key:=Range("B3:B" & lz), _
     SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With ActiveSheet.Sort
      .SetRange Range("A2:D" & lz)
      .Header = xlYes
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
  End With
 
' 11. Spalte C mit Spalte D tauschen (ich mache das immer mit ausschneiden.)
  Columns("C:C").Cut
  Columns("E:E").Insert Shift:=xlToRight
  Application.CutCopyMode = False

'Leere Zellen löschen
 Selection.SpecialCells(xlCellTypeBlanks).Select
   Selection.ClearContents

End Sub