Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
736to740
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
736to740
736to740
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Autofilter Selektion Ausgabe in Datei

Autofilter Selektion Ausgabe in Datei
02.03.2006 08:08:22
Strickner
Anforderung: Eine große Datei in mehrere kleine Excel-Dateien zerlegen - das VBA Makro simuliert daher einen Autofilteraufruf - nach Aufruf des Autofilters wird der Bereich kopiert - in eine neue Datei kopiert und dann gespeichert.
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Anforderung für was oder wenn
02.03.2006 11:28:37
serge
Nach Eingangsgruss...!
Anforderung?
Was soll das sein?
mit...............Gruss
Serge
AW: Anforderung für was oder wenn
02.03.2006 15:05:28
Strickner
Die Zeile Anforderung beschreibt, was das ganze Ding tun sollte ;-) - das VBA Ding ruft den Autofilter auf, kopiert die Daten und macht eine neue Datei - dort wird hineinkopiert, dann wird der nächste Filtereintrag aufgerufen usw. - allerdings ist nach 45 Mal Filter aufrufen Schluß - er will nicht weitermachen - ich habe aber insgesamt in der Ursprungstabelle 60 Filtereinträge (wenn man den Autofilter aufruft) - warum hört die Prozedur auf - das ist eigentlich die Frage.
PS: Einzelne Codefragmente hab' ich weggelassen (Dateien benennen, speichern, Dialoge aufrufen usw.)
Wer kann mir da helfen ?
Anzeige
AW: Anforderung für was oder wenn
02.03.2006 17:36:28
Fröhlich
Anrede
Frage
Gruß

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige