AW: Excel Makro funktioniert nur bei kleinen Listen
06.02.2014 16:40:13
fcs
Hallo Tobias,
deinen Fehler konnte ich jetzt nicht reproduzieren.
Verschiedene Probleme sind hier möglich:
Excel verliert sich in der riesigen Anzahl an Berechnungen.
Wenn die Anwendernamen auf seher viele Zellblöcke verteilt sind, dann kann es sein, dass Excel diese nicht mehr verwalten kann, wenn diese kopiert werden sollen.
Hier könnte es helfen, wenn die Liste nach den Anwendernamen sortiert wird bevor das FilterMakro gestartet wird.
Das Makro läuft aber elendig langsam.
Ich hab das Makro mal ein wenig umprogrammiert, so dass die Anwendernamen in ein Array geschrieben und abgearbeitet werden. Zur Prüfung, ob ein Anwendername schon abgearbeit wurde, wird eine andere Methode eingesetzt. So wird die Makroausführung sehr stark beschleunigt.
Das ListObject wird über seine Indexnummer angesprochen. Die ist hier immer 1. Das ist einfacher als mit dem Namen der Tabelle zu arbeiten.
Gruß
Franz
'Definition von Makroweit gültigen Variablen
Const SheetUrsprung As String = "Sheet1"
Const PfadSpeichern As String = "C:\TestTMP"
Const NameSpeichern As String = "MailFile_" '+ Anwender 1 usw.
Const ErsteSpalte As Long = 1 'Liste fängt in Spalte A an (A=1 usw), hier stehen _
_
die Anwender
Const ErsteZeile As Long = 2 'Einträge ab Zeile 2
Const MailAddSpalte As Long = 6 'Mailadressen in Spalte F = 6
Sub FiltereProAnwender()
On Error GoTo hell 'WICHTIG! Im Sub werden Displayalerts abgeschaltet, die müssen on Error _
UNBEDINGT wieder an!
Dim rAnwender As Range
Dim LastRow As Long
Dim wkbNew As Workbook
Dim wkbOld As Workbook
Dim NameOfSave As String
Dim TextPerson As String
Dim objCol As New Collection
Dim arrAnwender, lngAnw As Long
'das Workbook merken - denn später geht es in andere Workbooks!
Set wkbOld = ActiveWorkbook
With wkbOld.Sheets(SheetUrsprung)
'ACHTUNG! Autofilter darf bei Makrostart NICHT gesetzt sein! Reset per Makro
ResetAutoFilter
GoTo Weiter01 'Sortierung
.ListObjects(1).Sort.SortFields.Clear
.ListObjects(1).Sort.SortFields.Add _
Key:=.Range(.ListObjects(1).Name & "[[#All],[Anwender]]"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .ListObjects(1).Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Weiter01:
'letzte Zeile
LastRow = .Cells(.Rows.Count, ErsteSpalte).End(xlUp).Row
arrAnwender = .Range(.Cells(ErsteZeile, ErsteSpalte), .Cells(LastRow, ErsteSpalte))
Application.ScreenUpdating = False
'Alle Anwender durchlaufen
For lngAnw = LBound(arrAnwender, 1) To UBound(arrAnwender, 1) 'rAnwender In .Range(.Cells( _
ErsteZeile, ErsteSpalte), .Cells(LastRow, ErsteSpalte))
If arrAnwender(lngAnw, 1) "" Then
'Anwender 1 mal einer Collection hinzufügen, beim 2. mal gibt es Fehler _
mit Verzweigung nach NextAnwender
objCol.Add arrAnwender(lngAnw, 1), arrAnwender(lngAnw, 1)
'filtere nach Anwender
.ListObjects(1).Range.AutoFilter Field:=1, Criteria1:=arrAnwender(lngAnw, 1)
'nur gefilterten Teil der Tabelle kopieren
.ListObjects(1).Range.SpecialCells(xlCellTypeVisible).Copy
'neues Workbook öffnen und merken - neues Workbook ist automatisch im Focus!
Workbooks.Add Template:=xlWBATWorksheet
Set wkbNew = ActiveWorkbook
'gefilterte Tabelle einfügen und Spaltenbreiten anpassen
With ActiveSheet
.Range("A1").PasteSpecial
.Cells.EntireColumn.AutoFit
End With
'neues Workbook speichern (Displayalerts gegen "Datei existiert schon" Dialog)
NameOfSave = PfadSpeichern & "\" & NameSpeichern & arrAnwender(lngAnw, 1) & ".xlsx"
Application.DisplayAlerts = False
wkbNew.SaveAs Filename:=NameOfSave, FileFormat:=xlOpenXMLWorkbook, CreateBackup:= _
False
wkbNew.Close False
Application.DisplayAlerts = True
wkbOld.Activate 'Zur sicherheit
Else
'mache nix, wenn keine Text in Zelle
End If
NextAnwender:
Next lngAnw
Erase arrAnwender
End With
hell:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'Anwender kommt weiteres mal vor
Resume NextAnwender
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler in Sub FiltereProAnwender" & vbCrLf _
& "Fehlernummer: " & Err.Number & vbCrLf _
& "Fehlerbeschreibung: " & Err.Description
End Select
End With
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
'Autofilter wieder abschalten
ResetAutoFilter
MsgBox "Fertig"
End Sub
Sub ResetAutoFilter()
'Hier musst du eventuell den Namen des ListObject Table1 anpassen ...
With Sheets(SheetUrsprung).ListObjects(1).Range
.AutoFilter Field:=1
End With
End Sub