Es werden im VBA-Lauf nur 45 Dateien erzeugt, dann ist Schluß - gibt es eine interne Beschränkung, wieviele Werte im Autofilter selektierbar sind.
Option Explicit
Public Sub Filterkriterien()
'===============================================================================
'In der folgenden Anweisung wird das Sortierarray definiert - man könnte diese Zeile alternativ
'auch auf eine andere Spalte umstellen, einfacher ist aber das Verschieben der Selektionsspalte
'in die Spalte A
'===============================================================================
varArray = Range("A2:A10000")
Call sortieren(1, 9999, varArray)
For intIndex = 1 To 9999
If strMerker varArray(intIndex, 1) Then
intZaehler = intZaehler + 1
ReDim Preserve strArray(1 To intZaehler)
strArray(intZaehler) = varArray(intIndex, 1)
strMerker = varArray(intIndex, 1)
End If
Next
Application.ScreenUpdating = False
If IsEmpty(Pfad) = True Then
Pfad = GetDirectory("Bitte geben Sie einen gültigen Ausgabepfad an") & "\"
UserForm1.Pfad = Pfad
Worksheets("Initialisierung").Range("b1").Value = Pfad
End If
If Pfad = "\" Then
Pfad = GetDirectory("Bitte geben Sie einen gültigen Ausgabepfad an") & "\"
UserForm1.Pfad = Pfad
Worksheets("Initialisierung").Range("b1").Value = Pfad
End If
Pfad = Worksheets("Initialisierung").Range("b1").Value
Application.ScreenUpdating = False
'===============================================================================
'In der folgenden Schleife wird der Autofilter gesetzt und für jedes unterschiedliche Auftreten
'eine neue Tabelle erzeugt und in das Ausgabeverzeichnis gespeichert.
'===============================================================================
For intIndex = 1 To UBound(strArray)
sFilter = strArray(intIndex)
Debug.Print sFilter
Range("a1").AutoFilter Field:=1, Criteria1:=sFilter
Set rng = Range("a1").CurrentRegion.SpecialCells(xlCellTypeVisible)
Application.Workbooks.Add
rng.Copy Range("a1")
Columns("A:Z").Select
Columns("A:D").EntireColumn.AutoFit
Range("a1").Select
Dateiname = Pfad & "_" & sFilter & "_" & UM_ID & "_" & UM_Bezeichnung & ".xls"
On Error GoTo Fehler
ActiveWorkbook.SaveCopyAs Dateiname
ActiveWorkbook.Close
rng.Parent.Select
ActiveSheet.AutoFilterMode = False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Mldg = "Die Tabellenextraktion ist abgeschlossen" & Chr(13) & _
"Es wurden alle Tabellen in das Verzeichnis " & Pfad & " exportiert."
Stil = vbInformation
Titel = "Extraktion der Tabellen abgeschlossen"
Erg = MsgBox(Mldg, Stil, Titel)
Exit Sub
Fehler:
Mldg = "Beim Erzeugen der Tabellen ist ein Fehler aufgetreten" & Chr(13) & _
"Bitte prüfen Sie, ob Sie für den Speicherpfad Schreibrechte besitzen und " & Chr(13) & _
"ändern gegebenenfalls den Ausgabepfad"
Stil = vbCritical
Titel = "Abbruch der Tabellenextraktion"
End Sub
'Unterprogramm für Sortieren der Spalte A und Autofilter selektieren'
Private Sub sortieren(intUntergrenze As Integer, intObergrenze As Integer, _
varArray As Variant)
Dim intindex1 As Integer
Dim intindex2 As Integer
Dim strElement As String
Dim strZwischenspeicher As String
intindex1 = intUntergrenze
intindex2 = intObergrenze
strZwischenspeicher = varArray(Fix((intUntergrenze + intObergrenze) / 2), 1)
Do
Do While varArray(intindex1, 1) < strZwischenspeicher
intindex1 = intindex1 + 1
Loop
Do While strZwischenspeicher < varArray(intindex2, 1)
intindex2 = intindex2 - 1
Loop
If intindex1 <= intindex2 Then
strElement = varArray(intindex1, 1)
varArray(intindex1, 1) = varArray(intindex2, 1)
varArray(intindex2, 1) = strElement
intindex1 = intindex1 + 1
intindex2 = intindex2 - 1
End If
Loop Until intindex1 > intindex2
If intUntergrenze < intindex2 Then Call sortieren(intUntergrenze, intindex2, varArray)
If intindex1 < intObergrenze Then Call sortieren(intindex1, intObergrenze, varArray)
End Sub