Habe ca 800 Tabellenblätter .Die Zellen M3 aller Tabellenblätter haben unterschiedliche Zahlenwerte die sich auch verändern können.
Wie kann man nun die Tabellen nach der Wertgröße ihrer Zellen M3 sortieren lassen?
Danke im voraus Gruß Jürgen
Sub BlätterSortieren()
Dim WS As Worksheet
Dim X As Integer
Dim Y As Integer
Set WS = ActiveSheet
For X = 1 To ActiveWorkbook.Worksheets.Count
For Y = X To ActiveWorkbook.Worksheets.Count
If Worksheets(Y).Name < Worksheets(X).Name Then
Worksheets(Y).Move Before:=Worksheets(X)
End If
Next Y
Next X
WS.Activate
Set WS = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim objSh As Worksheet
Dim objTar As Worksheet
Dim blnExist As Boolean
Dim intNum As Integer
Dim lngLast As Long
Dim rng As Range
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
If Not Intersect(Target, Range("B5:B1000")) Is Nothing And Target.Count = 1 Then
If Target = "" Then Exit Sub
blnExist = False
intNum = Application.CountA(Range("B5:B1000"))
If Target.Offset(0, -1) = "" Then Target.Offset(0, -1) = intNum
For Each objSh In ThisWorkbook.Worksheets
If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
Set objTar = objSh
blnExist = True
Exit For
End If
Next objSh
If Not blnExist Then
Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
Sheets("Format").Cells.Copy Destination:=ActiveSheet.Cells
objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
ActiveSheet.Cells(6, 1).Value = Cells(Target.Row, 2)
DoEvents
Call Makros_TabBlatt_generieren(objTar.Name)
Me.Activate
End If
End If
If Not Intersect(Target, Range("P5:Q1000")) Is Nothing Then
blnExist = False
For Each objSh In ThisWorkbook.Worksheets
If objSh.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2) Then
Set objTar = objSh
blnExist = True
Exit For
End If
Next objSh
If Not blnExist Then
Set objTar = Worksheets.Add(after:=Sheets(Sheets.Count))
Sheets("Format").Cells.Copy Destination:=ActiveSheet.Cells
objTar.Name = Cells(Target.Row, 1) & " " & Cells(Target.Row, 2)
ActiveSheet.Cells(6, 1).Value = Cells(Target.Row, 2)
DoEvents
Call Makros_TabBlatt_generieren(objTar.Name)
Me.Activate
End If
With objTar
Set rng = .Range("E:E").Find(What:=Cells(Target.Row, 16).Value, _
LookIn:=xlFormulas, lookat:=xlWhole)
If Not rng Is Nothing Then
rng.Offset(0, 1) = Cells(Target.Row, 17)
Else
lngLast = .Cells(Rows.Count, 5).End(xlUp).Row + 1
If lngLast < 6 Then lngLast = 6
.Cells(lngLast, 5) = Cells(Target.Row, 16)
.Cells(lngLast, 6) = Cells(Target.Row, 17)
End If
End With
End If
Set objTar = Nothing
Set rng = Nothing
ErrorHandler:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationManual
.DisplayAlerts = True
End With
End Sub