AW: VBA
12.11.2010 22:16:18
Josef
Hallo Willi,
kopiere folgenden Code in das Modul der Tabelle "Haupt".
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub CommandButton1_Click()
Dim objSh As Worksheet
Dim lngLast As Long, lngRow As Long
On Error GoTo ErrExit
Application.ScreenUpdating = False
With Me
lngLast = Application.Max(2, .Cells(Rows.Count, 8).End(xlUp).Row)
For lngRow = 2 To lngLast
If .Cells(lngRow, 8) <> "" Then
If SheetExist(.Cells(lngRow, 8).Text) Then
Set objSh = Sheets(.Cells(lngRow, 8).Text)
Else
Set objSh = Worksheets.Add(after:=Sheets(Sheets.Count))
objSh.Name = .Cells(lngRow, 8).Text
End If
.Rows(lngRow).Copy objSh.Cells(Application.Max(2, objSh.Cells(objSh.Rows.Count, 8).End(xlUp).Row + 1), 1)
End If
Next
sortSheets
.Move before:=Sheets(1)
End With
ErrExit:
Application.ScreenUpdating = True
Set objSh = Nothing
End Sub
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Worksheets
If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function
Sub sortSheets(Optional Order As XlSortOrder = xlAscending, Optional AlphaNumeric As Boolean = True)
Dim lngA As Integer, lngB As Integer
With ActiveWorkbook
For lngA = 1 To .Sheets.Count
For lngB = 1 To .Sheets.Count - 1
If Format(UCase$(.Sheets(lngB + IIf(Order = xlAscending, 0, 1)).Name), _
IIf(AlphaNumeric, "000000000", "@")) > Format(UCase$(.Sheets(lngB + _
IIf(Order = xlAscending, 1, 0)).Name), IIf(AlphaNumeric, _
"000000000", "@")) Then
.Sheets(lngB).Move after:=.Sheets(lngB + 1)
End If
Next
Next
End With
End Sub
Gruß Sepp