Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.
Clever-Excel-Forum › Office-Anwendungen › Excel v
Excel VBA Hilfe benoetigt

Thema geschlossen 
Baumstrukturmodus
Excel VBA Hilfe benoetigt
Markus1971 Offline
CEF Einsteiger
*
Registriert seit: 14.07.2016
Version(en): 2013
#1
24.03.2017, 16:15 (Dieser Beitrag wurde zuletzt bearbeitet: 24.03.2017, 17: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
Antworten Top
Fennek Offline
Benutzer
Registriert seit: 06.12.2015
Version(en): 2016
#2
24.03.2017, 16: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
Antworten Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#3
24.03.2017, 17:13 (Dieser Beitrag wurde zuletzt bearbeitet: 24.03.2017, 17: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
Antworten Top
Markus1971 Offline
CEF Einsteiger
ThreadStarter
*
Registriert seit: 14.07.2016
Version(en): 2013
#4
27.03.2017, 11:11 (Dieser Beitrag wurde zuletzt bearbeitet: 27.03.2017, 11: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
Antworten Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#5
27.03.2017, 17: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
Antworten Top
Markus1971 Offline
CEF Einsteiger
ThreadStarter
*
Registriert seit: 14.07.2016
Version(en): 2013
#6
28.03.2017, 14: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
Antworten Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#7
29.03.2017, 00:01 (Dieser Beitrag wurde zuletzt bearbeitet: 29.03.2017, 09: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
Antworten Top
Markus1971 Offline
CEF Einsteiger
ThreadStarter
*
Registriert seit: 14.07.2016
Version(en): 2013
#8
29.03.2017, 15: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
Antworten Top
Kuwer Offline
Excelanwender mit VBA
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
#9
29.03.2017, 15:54
Hallo Markus,

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

Gruß Uwe
Suchen
Antworten Top
Thema geschlossen 


Gehe zu:


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