Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1240to1244
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Autofilter mit VMA

Autofilter mit VMA
Hermann
Hallo,
ich poste meinen archivierten Beitrag nochmal, da noch nicht abgeschlossen.
Die Public Funktion habe ich ins Modul gestellt, ist doch korrekt, oder ?
Die unten beschriebene Fehlermeldung kommt aber immer noch, auch wenn ich in der Spalte 7 ( mit Autofilter) dafür Sorge das keine Sonderzeichen vorkommen.
Gruß Hermann
Hallo ,
in einem früheren Beitrag habe ich das bereits archivierte Thema schon mal eröffnet, kam aber wg Umzug nicht mehr dazu mich darüm zu kümmern.
Hier nun ein erneuter Versuch diesmal hoffentlich verständlicher formulert.
Wie kann man mit VBA die Eintrage (zB. siehe unten Test1, Test2 etc.) im Autofilter der Spalte 7 nach und nach selektieren, wobei die Anzahl der Einträge variieren kann.
Selection.AutoFilter
Selection.AutoFilter Field:=7, Criteria1:="Test1"
Cells.Select
Selection.Copy
...... (hier werden weitere Aktionen mit der kopierten Selektion durchgeführt)
Selection.AutoFilter Field:=7, Criteria1:="Test2"
Cells.Select
Selection.Copy
etc...
Gruß
Hermann
Hallo Hermann,
die Filterwerte der Spalte kann man in einer For-Next-Schleife in eine sogenannte Collection einsammeln. Durch festlegen des Key-Parameters werden alle Werte nur einmal eingelesen.
In einer 2. For-Next-Schleife werden dann die Werte der Collection als Filterwerte setzen.
Wie dann das Kopieren der jeweils gefilterten Werten optimal ausgeführt werden kann ist aus deinem Code ja nicht ersichtlich.
Ich hab es mal so eingerichtet, dass eine neu Arbeitsmappe angelegt wird und die Werte jedes Filters in ein eigenes Blatt kopiert werden.
Gruß
Franz
Sub aaTest()
Dim objRange As Range, objZelle As Range, objRangeFilter As Range
Dim wksAktiv As Worksheet, wbZiel As Workbook, wksZiel As Worksheet
Dim objCollection As New Collection, intI As Integer, boolAdd As Boolean
On Error GoTo Fehler
Set wksAktiv = ActiveSheet
'Prüfen, ob Autofilter schon aktiv
If wksAktiv.AutoFilterMode = True Then
If wksAktiv.FilterMode = True Then
wksAktiv.ShowAllData
End If
Else
Selection.AutoFilter
End If
'Autofilterbereich der aktiven Tabelle
Set objRangeFilter = wksAktiv.AutoFilter.Range
'Sortierte Liste ohne Doppelte der Werte in Spalte 7 des Autofilter-Bereichs erstellen
Set objRange = wksAktiv.AutoFilter.Range.Columns(7)
For Each objZelle In objRange.Cells
If objZelle.Row wksAktiv.AutoFilter.Range.Row Then
If objCollection.Count = 0 Then
objCollection.Add objZelle.Value, Key:=CStr(objZelle.text)
Else
For intI = 1 To objCollection.Count
If objZelle.Value objCollection.Add objZelle.Value, Key:=CStr(objZelle.text), before:=intI
Exit For
End If
Next
If Not intI objCollection.Add objZelle.Value, Key:=CStr(objZelle.text)
End If
End If
End If
Next
'Liste der Filterwerte abarbeiten
Application.ScreenUpdating = False
For intI = 1 To objCollection.Count
'Zieldatei anlegen (neue Arbeitsmappe)
If wbZiel Is Nothing Then
'Aktive Tabelle als Muster in eine neue Arbeitsmappe kopieren
wksAktiv.Copy
Set wbZiel = ActiveWorkbook
wbZiel.Worksheets(1).UsedRange.Clear 'alle Inhalte im Muster löschen
wbZiel.Worksheets(1).Name = "$$Muster$$" 'Name darf nicht als Filterwert vorkommen!!!
' wksAktiv.Parent.Activate
End If
'Daten filtern
objRangeFilter.AutoFilter Field:=7, Criteria1:=objCollection(intI)
With wksAktiv
Set objRange = .Range(.Cells(1, 1), .Cells.SpecialCells(xlCellTypeLastCell))
End With
'Zieltabelle anlegen - Mustertabelle kopieren
With wbZiel
.Worksheets(1).Copy after:=.Sheets(.Sheets.Count)
Set wksZiel = .Worksheets(.Sheets.Count)
End With
Select Case objCollection(intI)
Case "" 'nicht zulässig als Blattname
wksZiel.Name = "(Leer)"
Case Else
wksZiel.Name = CStr(objCollection(intI))
End Select
'gefilterte Daten kopieren
objRange.Copy wksZiel.Cells(1, 1)
' wksAktiv.Parent.Activate
Next
Application.CutCopyMode = False
If Not wbZiel Is Nothing Then
'Mustertabelle in Zieldatei wieder löschen
Application.DisplayAlerts = False
wbZiel.Worksheets(1).Delete
Application.DisplayAlerts = True
End If
Application.ScreenUpdating = True
wksAktiv.ShowAllData
wksAktiv.AutoFilterMode = False
Fehler:
With Err
Select Case .Number
Case 0 'alles ok
Case 457 'doppelter Eintrag in Collection
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Set objCollection = Nothing: Set wbZiel = Nothing: Set wksAktiv = Nothing: set wksZiel = _
Nothing
End Sub
Hallo Franz,
das ist genau was ich gesucht habe !!
Beim Testen ist nun folg aufgefallen:
Bei der Anlage des 2 .Tab.blattes in der neuen Zieldatei kommt die Fehlermeldung, das bei Umbenennung des Blattnamens die Umbennung des Blattnamens unzulässig ist. Wenn ich mir die neue Zieldatei aber ansehe sind die Blätter $$Muster$$ und $$Muster$$(2) angelegt, was eigentlich nicht gegen die Blattnamenkonvention spricht.
Ferner scheint das Kopieren der Daten in die Zieldatei nicht zufunktionieren. Im 1. Blatt ($$Muster$$) stehen keine kopierten Daten.
Viele Grüße
Hermann
Hallo Hermann,
es gibt ein paar Zeichen, die sind als Blattname nicht zulässig. Schein kommen die in Spalte 7 der Tabelle vor.
Das Blatt "$$Muster$$" wird ja zu beginn des Makros ohne Daten kreiert. Wenn das Makro ohne Fehler durchläuft, dann wird nach dem abarbeiten aller Filter wieder gelöscht.
Mit den nachfolgenden Ergänzunge sollte es funktionieren. Die unzulässigen Zeichen werden durche einen "_" ersetzt.
Gruß
Franz
Sub aaTest()
Dim objRange As Range, objZelle As Range, objRangeFilter As Range
Dim wksAktiv As Worksheet, wbZiel As Workbook, wksZiel As Worksheet
Dim objCollection As New Collection, intI As Integer, boolAdd As Boolean
On Error GoTo Fehler
Set wksAktiv = ActiveSheet
'Prüfen, ob Autofilter schon aktiv
If wksAktiv.AutoFilterMode = True Then
If wksAktiv.FilterMode = True Then
wksAktiv.ShowAllData
End If
Else
Selection.AutoFilter
End If
'Autofilterbereich der aktiven Tabelle
Set objRangeFilter = wksAktiv.AutoFilter.Range
'Sortierte Liste ohne Doppelte der Werte in Spalte 7 des Autofilter-Bereichs erstellen
Set objRange = wksAktiv.AutoFilter.Range.Columns(7)
For Each objZelle In objRange.Cells
If objZelle.Row wksAktiv.AutoFilter.Range.Row Then
If objCollection.Count = 0 Then
objCollection.Add objZelle.Value, Key:=CStr(objZelle.text)
Else
For intI = 1 To objCollection.Count
If objZelle.Value objCollection.Add objZelle.Value, Key:=CStr(objZelle.text), before:=intI
Exit For
End If
Next
If Not intI objCollection.Add objZelle.Value, Key:=CStr(objZelle.text)
End If
End If
End If
Next
'Liste der Filterwerte abarbeiten
Application.ScreenUpdating = False
For intI = 1 To objCollection.Count
'Zieldatei anlegen (neue Arbeitsmappe)
If wbZiel Is Nothing Then
'Aktive Tabelle als Muster in eine neue Arbeitsmappe kopieren
wksAktiv.Copy
Set wbZiel = ActiveWorkbook
wbZiel.Worksheets(1).UsedRange.Clear 'alle Inhalte im Muster löschen
wbZiel.Worksheets(1).Name = "$$Muster$$" 'Name darf nicht als Filterwert vorkommen!!!
' wksAktiv.Parent.Activate
End If
'Daten filtern
objRangeFilter.AutoFilter Field:=7, Criteria1:=objCollection(intI)
With wksAktiv
Set objRange = .Range(.Cells(1, 1), .Cells.SpecialCells(xlCellTypeLastCell))
End With
'Zieltabelle anlegen - Mustertabelle kopieren
With wbZiel
.Worksheets(1).Copy after:=.Sheets(.Sheets.Count)
Set wksZiel = .Worksheets(.Sheets.Count)
End With
Select Case objCollection(intI)
Case "" 'nicht zulässig als Blattname
wksZiel.Name = "(Leer)"
Case Else
wksZiel.Name = CheckSheetName(CStr(objCollection(intI)))
End Select
'gefilterte Daten kopieren
objRange.Copy wksZiel.Cells(1, 1)
' wksAktiv.Parent.Activate
Next
Application.CutCopyMode = False
If Not wbZiel Is Nothing Then
'Mustertabelle in Zieldatei wieder löschen
Application.DisplayAlerts = False
wbZiel.Worksheets(1).Delete
Application.DisplayAlerts = True
End If
Application.ScreenUpdating = True
wksAktiv.ShowAllData
wksAktiv.AutoFilterMode = False
Fehler:
With Err
Select Case .Number
Case 0 'alles ok
Case 457 'doppelter Eintrag in Collection
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Set objCollection = Nothing
End Sub
Public Function CheckSheetName(ByVal sName As String) As String
'entfernt unzulässige Zeichen aus einem Blattnamen
CheckSheetName = sName
If CheckSheetName = "" Then CheckSheetName = "(Leer)"
If Left(CheckSheetName, 1) = "'" Then CheckSheetName = "_" & Mid(sName, 2)
CheckSheetName = VBA.Replace(CheckSheetName, "[", "_")
CheckSheetName = VBA.Replace(CheckSheetName, "]", "_")
CheckSheetName = VBA.Replace(CheckSheetName, ":", "_")
CheckSheetName = VBA.Replace(CheckSheetName, "/", "_")
CheckSheetName = VBA.Replace(CheckSheetName, "\", "_")
CheckSheetName = VBA.Replace(CheckSheetName, "*", "_")
CheckSheetName = VBA.Replace(CheckSheetName, "?", "_")
End Function

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Autofilter mit VBA, Daten exportieren
10.12.2011 08:24:47
fcs
Hallo Hermann,
die einzige Fehler-Möglichkeit, die mir jetzt noch einfällt, sind Einträge in Spalte 7 mit mehr als 31 Zeichen.
Ich hab die Makros mal entsprechend angepasst.
Damit es beim Abschneiden langer Inhalte nicht zu doppelten Blattnamen kommen kann hab ich am Anfang der Blattnamen zusätzlich eine Zählnummer eingefügt.
Gruß
Franz
Beispieldatei mit Makros
https://www.herber.de/bbs/user/77912.xls
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige