Clever-Excel-Forum › Office-Anwendungen › Excel v
Excel VBA Hilfe benoetigt

Thema geschlossen 
Baumstrukturmodus
Excel VBA Hilfe benoetigt
Markus1971 Offline
pausiert
Registriert seit: 14.07.2016
Version(en): 2013
#1
24.03.2017, 17:15 (Dieser Beitrag wurde zuletzt bearbeitet: 24.03.2017, 18:09 von Markus1971.)
Hallo zusammen

ich arbeite derzeit an einem kleinen Excel Project in welchen ich VBA nutzen möchte.
Es geht darum das ich ca. 20 Worksheets exakt gleich sortieren möchte.
 
Ich habe mir nun ein kleines Makro gemacht welches dieses auch brav erledigt. Allerdings war ich nicht in der Lage dieses besonders smart zu programmieren...
 
Das Problem welches ich habe, ist wenn jemand ein Worksheet umbenennt funktioniert die ganze Sache nicht mehr, da ich die Worksheet Namen genutzt habe.
Auch sind in den 20 Worksheets zwei enthalten, Sheet11 und Sheet12, welche nicht sortiert werden duerfen.
Des Weiteren gefallt mir nicht das mein Makro wenn alle 20 Sheets inkludiert sind riesig aufgebläht und lang ist. Ich bin mir sicher dass man dies auch eleganter mit z.B. einer Schleife lösen kann. Leider bin ich totaler Anfänger und bin erst dabei die Grundlangen mittels eines Buches zu erlernen.

Ich hoffe das jemand von Euch sich das mal anschauen könnte und mir zeigen könnte wie man es besser macht.

Vielen Dank
Markus



Code:
Sub Macro1()
' Macro1 - Select and Sort
'Selcect Sheet
    Sheets("CC 1111 LC").Select
'Selcect all Cells and remove all subtotals
    Cells.Select
    Selection.RemoveSubtotal
'Selcect range and sort
    Range("A2:Y602").Select
    ActiveWorkbook.Worksheets("CC 1111 LC").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("CC 1111 LC").Sort.SortFields.Add Key:=Range( _
        "A3:A602"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("CC 1111 LC").Sort.SortFields.Add Key:=Range( _
        "C3:C602"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("CC 1111 LC").Sort.SortFields.Add Key:=Range( _
        "D3:D602"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("CC 1111 LC").Sort
        .SetRange Range("A2:Y602")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'Coursor position
    Range("F3").Select
   
'Selcect Sheet
    Sheets("CC 2222 LC").Select
'Selcect all Cells and remove all subtotals
    Cells.Select
    Selection.RemoveSubtotal
'Selcect range and sort
    Range("A2:Y602").Select
    ActiveWorkbook.Worksheets("CC 2222 LC").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("CC 2222 LC").Sort.SortFields.Add Key:=Range( _
        "A3:A602"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("CC 2222 LC").Sort.SortFields.Add Key:=Range( _
        "C3:C602"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("CC 2222 LC").Sort.SortFields.Add Key:=Range( _
        "D3:D602"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("CC 2222 LC").Sort
        .SetRange Range("A2:Y602")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'Coursor position
    Range("F3").Select
'Selcect Sheet
    Sheets("CC 3333 LC").Select
'Selcect all Cells and remove all subtotals
    Cells.Select
    Selection.RemoveSubtotal
'Selcect range and sort
    Range("A2:Y602").Select
    ActiveWorkbook.Worksheets("CC 3333 LC").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("CC 3333 LC").Sort.SortFields.Add Key:=Range( _
        "A3:A602"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("CC 3333 LC").Sort.SortFields.Add Key:=Range( _
        "C3:C602"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    ActiveWorkbook.Worksheets("CC 3333 LC").Sort.SortFields.Add Key:=Range( _
        "D3:D602"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("CC 3333 LC").Sort
        .SetRange Range("A2:Y602")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'Coursor position
    Range("F3").Select
   
    Sheets("Sorting").Select
    Range("E5:F28").Select
End Sub


Angehängte Dateien Thumbnail(s)
   
Suchen
Top
Fennek Offline
Benutzer
Registriert seit: 06.12.2015
Version(en): 2016
#2
24.03.2017, 17:29
Hallo,

sieh dir mal

http://office-loesung.de/p/viewtopic.php?f=166&t=734522&sid=bcb2020aa0e48cead5f4986438752315

an, insbesondere die Beiträge von snb.

mfg
Suchen
Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#3
24.03.2017, 18:13 (Dieser Beitrag wurde zuletzt bearbeitet: 24.03.2017, 18:13 von Kuwer.)
Hallo Markus,

Sub SortiereBlaetter()
  Dim oWs As Worksheet
  For Each oWs In ThisWorkbook.Worksheets
    Select Case oWs.CodeName
      Case "Sheet11", "Sheet12"
        'tue nichts
      Case Else
        With oWs
          .Cells.RemoveSubtotal
          With .Range("A2:Y602")
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, DataOption1:=xlSortNormal, _
                  Key2:=.Range("C2"), Order2:=xlAscending, DataOption2:=xlSortNormal, _
                  Key3:=.Range("D2"), Order3:=xlAscending, DataOption3:=xlSortNormal, _
                  Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
          End With
        End With
    End Select
  Next oWs
End Sub

Gruß Uwe
Suchen
Top
Markus1971 Offline
pausiert
ThreadStarter
Registriert seit: 14.07.2016
Version(en): 2013
#4
27.03.2017, 12:11 (Dieser Beitrag wurde zuletzt bearbeitet: 27.03.2017, 12:14 von Markus1971.)
Hallo Uwe,

erst mal 1000 Dank für Deine Hilfe, soweit funktioniert das alles prima.

Ich habe nun versucht eine weitere Aktionen in das Makro zu integrieren, was nun auch wieder nicht recht klappen will…
Ich möchte erreichen, das nach dem sortieren des Bereiches A2:Y602 in demselben Bereich Subtotals (Summe), nach Änderung in Spalte C (3), in den Spalten F bis Y (5-25) berechnet werden.

Uber Deine/Eure erneute Hilfe wäre ich sehr dankbar.

Vielen Dank
Markus



Code:
Sub SortA()
  Dim oWs As Worksheet
  For Each oWs In ThisWorkbook.Worksheets
    Select Case oWs.CodeName
      Case "Sheet11", "Sheet12"
        'tue nichts
      Case Else
     
        With oWs
          .Cells.RemoveSubtotal
         
          With .Range("A2:Y602")
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, DataOption1:=xlSortNormal, _
                  Key2:=.Range("C2"), Order2:=xlAscending, DataOption2:=xlSortNormal, _
                  Key3:=.Range("D2"), Order3:=xlAscending, DataOption3:=xlSortNormal, _
                  Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
          End With
         
          With .Range("A2:Y602")
             Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(5, 6, 7, 8, _
             9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), Replace:=True, _
             PageBreaks:=False, SummaryBelowData:=True
             Range("F3").Select
          End With
         
        End With
    End Select
  Next oWs
End Sub
Suchen
Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#5
27.03.2017, 18:27
Hallo Markus,

so vielleicht?

Sub SortA()
 Dim oWs As Worksheet
 For Each oWs In ThisWorkbook.Worksheets
   Select Case oWs.CodeName
     Case "Sheet11", "Sheet12"
       'tue nichts
     Case Else
       With oWs
         .Cells.RemoveSubtotal
         With .Range("A2:Y602")
           .Sort Key1:=.Range("A2"), Order1:=xlAscending, DataOption1:=xlSortNormal, _
                 Key2:=.Range("C2"), Order2:=xlAscending, DataOption2:=xlSortNormal, _
                 Key3:=.Range("D2"), Order3:=xlAscending, DataOption3:=xlSortNormal, _
                 Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
           .Subtotal GroupBy:=3, Function:=xlSum, _
             TotalList:=Array(5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), _
             Replace:=True, PageBreaks:=False, SummaryBelowData:=True
         End With
       End With
   End Select
 Next oWs
End Sub

Gruß Uwe
Suchen
Top
Markus1971 Offline
pausiert
ThreadStarter
Registriert seit: 14.07.2016
Version(en): 2013
#6
28.03.2017, 15:59
Hallo Uwe,
 
Vielen Dank für Deine Hilfe, das Skript funktioniert soweit gut.

Allerdings ist das Sortieren mit anschießenden Subtotals sehr langsam, es vergehen einige Minuten bis das Skript durchgelaufen ist. Mir ist klar dass es pro Worksheet 1.050 Subtotals sind, was bei 20 Worksheets 21.000 Subtotals ergibt.

Kann es aber sein das hier irgendetwas in einer Art „Endlosschleife“ läuft? Oder gibt es eine Möglichkeit den Ablauf zu beschleunigen?
Sollte vielleicht noch erwähnen dass ich auf Excel 2013 arbeite.

Vielen Dank
Markus

Sub SortA()
 Dim oWs As Worksheet
 For Each oWs In ThisWorkbook.Worksheets
   Select Case oWs.CodeName
     Case "Sheet11", "Sheet12"
       'tue nichts
     Case Else
       With oWs
         .Cells.RemoveSubtotal
         With .Range("A2:Y602")
           .Sort Key1:=.Range("A2"), Order1:=xlAscending, DataOption1:=xlSortNormal, _
                 Key2:=.Range("C2"), Order2:=xlAscending, DataOption2:=xlSortNormal, _
                 Key3:=.Range("D2"), Order3:=xlAscending, DataOption3:=xlSortNormal, _
                 Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
           .Subtotal GroupBy:=3, Function:=xlSum, _
             TotalList:=Array(5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), _
             Replace:=True, PageBreaks:=False, SummaryBelowData:=True
         End With
       End With
   End Select
 Next oWs
End Sub
Suchen
Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#7
29.03.2017, 01:01 (Dieser Beitrag wurde zuletzt bearbeitet: 29.03.2017, 10:23 von Kuwer. Bearbeitungsgrund: Berechnungsbehandlung nun außerhalb der Schleife )
Hallo Markus,

hier wird die Berechnung temporär auf manuell gestellt. Vielleicht geht es so schneller.

Sub SortA()
  Dim lngBerechnungsmodus As Long
  Dim oWs As Worksheet
  lngBerechnungsmodus = Application.Calculation
  Application.Calculation = xlCalculationManual
  For Each oWs In ThisWorkbook.Worksheets
    Select Case oWs.CodeName
      Case "Sheet11", "Sheet12"
        'tue nichts 
      Case Else
        With oWs
          .Cells.RemoveSubtotal
          With .Range("A2:Y602")
            .Sort Key1:=.Range("A2"), Order1:=xlAscending, DataOption1:=xlSortNormal, _
                  Key2:=.Range("C2"), Order2:=xlAscending, DataOption2:=xlSortNormal, _
                  Key3:=.Range("D2"), Order3:=xlAscending, DataOption3:=xlSortNormal, _
                  Header:=xlYes, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
            .Subtotal GroupBy:=3, Function:=xlSum, _
              TotalList:=Array(5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25), _
              Replace:=True, PageBreaks:=False, SummaryBelowData:=True
          End With
        End With
    End Select
  Next oWs
  Application.Calculation = lngBerechnungsmodus
End Sub


Gruß Uwe
Suchen
Top
Markus1971 Offline
pausiert
ThreadStarter
Registriert seit: 14.07.2016
Version(en): 2013
#8
29.03.2017, 16:37
Hallo Uwe
 
mal wieder vielen Dank für Deine prompte Antwort.
Leider wird die Berechnung auch nicht schneller durch die manuelle Berechnung.
 
Es sind wahrscheinlich einfach zu viele Berechnungen. Werde versuchen die Datei in "Teilstücke" zu zerlegen.
 
Vielen Dank
Markus
Suchen
Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#9
29.03.2017, 16:54
Hallo Markus,

hattest Du die neueste Codeversion genommen? Ich hatte da noch was geändert.

Gruß Uwe
Suchen
Top
Thema geschlossen 


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste