Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Blattsortierung klappt nicht | Herbers Excel-Forum


Betrifft: Blattsortierung klappt nicht von: Andre Reichstein
Geschrieben am: 24.12.2009 13:35:16

Hallo Ihr lieben Leute,

ich bin heute das erste Mal hier und hoffe, dass mir vielleicht geholfen wird. Ich habe eine Exceltabelle,
in der die Blätter mit 1.KW, 2. KW, usw. benannt werden sollen. Das klappt soweit ganz gut.

Nur sollen die Tabellenblätter auch sortiert werden. Wenn man also die 4. KW erstellt, nach der 7. KW, dann wird sie auch davor einsortiert. Nur erstellt man zum Beispiel die 31. KW, dann wird sie hinter der 3. KW einsortiert und nicht hinter der 7. KW.

  

Betrifft: AW: Blattsortierung klappt nicht von: Andre Reichstein
Geschrieben am: 24.12.2009 13:36:11

Oh. entschuldigt.

Bielen Dank für Eure Mühen und schöne Tage wünsche ich allen hier.

Gruß Andre


  

Betrifft: AW: Blattsortierung klappt nicht von: Peter Feustel
Geschrieben am: 24.12.2009 14:35:27

Hallo Andre,

so sollte das funktionieren:

Sub Tabellenblaetter_Sortieren_II()

'   wenn anstatt "Worksheets" nur "Sheets"
'   genommen wird, werden Diagramme usw. mitsortiert

Dim i  As Integer
Dim y  As Integer

   For i = 1 To Worksheets.Count
      For y = Worksheets.Count To 2 Step -1
         If Worksheets(y).Name < Worksheets(y - 1).Name Then _
            Worksheets(y).Move before:=Worksheets(y - 1)
      Next y
   Next i

End Sub
Gruß und frohe Weihnachten

Peter


  

Betrifft: Blattsortierung und Neueanlage-Position von: Erich G.
Geschrieben am: 25.12.2009 14:00:34

Hi Andre,
zum Anlegen eines neuen Blattes könntest du das hier probieren:

Sub testAnlegen()
   Tabellenblatt_Anlegen 33 ' KW, für die das Blatt angelegt werden soll
End Sub

Sub Tabellenblatt_Anlegen(intKW As Integer)
   Dim ii As Integer, jj As Integer, strN As String

   ReDim arrN(1 To Worksheets.Count)
   For ii = 1 To Worksheets.Count
      arrN(ii) = 99
      jj = InStr(Worksheets(ii).Name, ".") - 1
      If jj > 0 Then
         If IsNumeric(Left$(Worksheets(ii).Name, jj)) Then _
            arrN(ii) = CInt(Left$(Worksheets(ii).Name, jj)) ' Nummern der alten Blätter
      End If
   Next ii
   strN = CStr(intKW) & ". KW"                              ' Name des neuen Blatts
   For ii = 1 To Worksheets.Count
      Select Case arrN(ii)
         Case Is = intKW
            MsgBox "Blatt " & strN & " existiert bereits."     ' keine Anlage - doppelt
            Exit Sub
         Case Is > intKW
            Worksheets.Add(before:=Worksheets(ii)).Name = strN ' Anlage
            Exit Sub
      End Select
   Next ii
   Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = strN ' neues letztes Blatt
End Sub
Das setzt natürlich voraus, dass die vorher bereits existierenden Blätter sortiert sind.

Erreichen kannst du den Sort hiermit:
Sub Tabellenblaetter_Sortieren_3()
                                 ' wenn anstatt "Worksheets" nur "Sheets" genommen wird,
                                 ' werden Diagramme usw. mitsortiert
   Dim ii As Integer, jj As Integer, mm As Integer, arrN() As Integer
   
   ReDim arrN(1 To Worksheets.Count)
   For ii = 1 To Worksheets.Count
      arrN(ii) = 99
      jj = InStr(Worksheets(ii).Name, ".") - 1
      If jj > 0 Then
         If IsNumeric(Left$(Worksheets(ii).Name, jj)) Then _
            arrN(ii) = CInt(Left$(Worksheets(ii).Name, jj))  ' Nummern der Blätter
      End If
   Next ii
   For ii = 1 To Worksheets.Count - 1
      For jj = ii + 1 To Worksheets.Count
         If arrN(jj) < arrN(ii) Then
            mm = arrN(ii):     arrN(ii) = arrN(jj):     arrN(jj) = mm
            Worksheets(jj).Move before:=Worksheets(ii)
         End If
      Next jj
   Next ii
End Sub
Das Problem hättest du nicht, wenn du die Blätter "01. KW" usw. nennen würdest - mit immer 2 Stellen für die Woche.

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort


  

Betrifft: Blattsortierung korrigiert von: Erich G.
Geschrieben am: 28.12.2009 17:50:43

Hi Andre,
bei der Blattsortierung traue ich meinem Code nicht über den Weg (ohne genauer getestet zu haben).
Die richtige Neuanlage sollte funzen wie gehabt.

Probier mal den Sort mit

Sub Tabellenblaetter_Sortieren_4()
                                 ' wenn anstatt "Worksheets" nur "Sheets" genommen wird,
                                 ' werden Diagramme usw. mitsortiert
   Dim intB As Long, ii As Long, jj As Long, mm As Long, arrN()
   
   intB = Worksheets.Count
   ReDim arrN(1 To intB, 1)
   For ii = 1 To intB
      arrN(ii, 1) = Worksheets(ii).Name                  ' Namen   der Blätter
      arrN(ii, 0) = 99
      jj = InStr(Worksheets(ii).Name, ".") - 1
      If jj > 0 Then
         If IsNumeric(Left$(Worksheets(ii).Name, jj)) Then _
            arrN(ii, 0) = CInt(Left$(Worksheets(ii).Name, jj)) ' Nummern der Blätter
      End If
   Next ii
   BubbleSort_01 arrN()
   For ii = 1 To intB - 1
      If Worksheets(arrN(ii, 1)).Index > ii Then _
         Worksheets(arrN(ii, 1)).Move before:=Worksheets(ii)
   Next ii
End Sub

Sub BubbleSort_01(ByRef arrVar())                           ' BubbleSort
   Dim OG As Long, i As Long, h0, h1

   OG = UBound(arrVar, 1)
   Do
      For i = 1 To OG - 1
         If arrVar(i, 0) > arrVar(i + 1, 0) Then
            h0 = arrVar(i, 0)
            h1 = arrVar(i, 1)
            arrVar(i, 0) = arrVar(i + 1, 0)
            arrVar(i, 1) = arrVar(i + 1, 1)
            arrVar(i + 1, 0) = h0
            arrVar(i + 1, 1) = h1
         End If
      Next i
      OG = OG - 1
   Loop While OG > 1
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort