teste mal.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub manu()
Dim objNewWB As Workbook
Dim rng As Range, rngFind As Range, rngExport As Range
Dim vntList As Variant, vntRange As Variant
Dim lngIndex As Long, lngRow() As Long, lngFormat As Long
Dim strfirst As String, strExt As String
Dim lngCalc As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
With Sheets("Termine") 'Tabellennamen anpassen!
Set rng = .Range("R1:W22") 'bereich evtl. anpassen!
vntRange = rng
vntList = toArraySorted(vntRange)
For lngIndex = LBound(vntList) To UBound(vntList)
Set rngExport = Nothing
Set rngFind = Nothing
Redim lngRow(0)
Set rngFind = rng.Find(What:=vntList(lngIndex), LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, After:=rng.Cells(1, 1))
If Not rngFind Is Nothing Then
strfirst = rngFind.Address
Do
If IsError(Application.Match(rngFind.Row, lngRow, 0)) Then
If rngExport Is Nothing Then
Set rngExport = rngFind.EntireRow
Else
Set rngExport = Union(rngExport, rngFind.EntireRow)
End If
Redim Preserve lngRow(UBound(lngRow) + 1)
lngRow(UBound(lngRow)) = rngFind.Row
End If
Set rngFind = rng.FindNext(rngFind)
Loop While Not rngFind Is Nothing And strfirst <> rngFind.Address
End If
If Not rngExport Is Nothing Then
Set objNewWB = Workbooks.Add(xlWBATWorksheet)
rngExport.Copy objNewWB.Sheets(1).Range("A1")
objNewWB.Sheets(1).Name = vntList(lngIndex)
getFileExtAndFormat objNewWB, strExt, lngFormat
objNewWB.SaveAs ThisWorkbook.Path & "\" & vntList(lngIndex) & strExt, lngFormat
objNewWB.Close
End If
Next
End With
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'manu'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul2"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objNewWB = Nothing
Set rngExport = Nothing
Set rngFind = Nothing
Set rng = Nothing
End Sub
Private Function toArraySorted(Field As Variant, Optional Uniqe As Boolean = True) As Variant
Dim objArrayList As Object
Dim lngR As Long, lngC As Long
On Error GoTo ErrExit
Set objArrayList = CreateObject("System.Collections.Arraylist")
With objArrayList
For lngR = LBound(Field, 1) To UBound(Field, 1)
For lngC = LBound(Field, 2) To UBound(Field, 2)
If Not .Contains(Trim(Field(lngR, lngC))) Or Not Uniqe Then
If Field(lngR, lngC) <> "" Then .Add Trim(Field(lngR, lngC))
End If
Next
Next
.Sort
toArraySorted = .toArray
End With
Exit Function
ErrExit:
toArraySorted = -1
End Function
Private Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
With WB
If Val(Application.Version) < 12 Then
strExt = ".xls": lngFormat = -4143
Else
Select Case WB.FileFormat
Case 51: strExt = ".xlsx": lngFormat = 51
Case 52:
If .HasVBProject Then
strExt = ".xlsm": lngFormat = 52
Else
strExt = ".xlsx": lngFormat = 51
End If
Case 56: strExt = ".xls": lngFormat = 56
Case Else: strExt = ".xlsb": lngFormat = 50
End Select
End If
End With
End Function