Ausdruck mit Filter

josef24

Erfahrenes Mitglied
Guten Morgen.
Ich habe ein VBA Kode (EXCEL 2007) wo ich mittels Vorgabe die Filterung für ausdrucke festlege. Bisher kann ich nur einen Filter (Zahl) vorgeben womit dann der Ausdruck aktiviert wird. Ich möchte aber gleichzeitig die Möglichkeit haben eine Auswahl von bis in den Filterkriterien in der Inputbox vor zu geben. Z. B. 1 und 3 und 7 oder auch 2 bis 5. Hat hier vielleicht jemand eine Idee wie man dies verwirklichen kann? Danke schon jetzt für eure Unterstützung, Gruß Josef
Code:
Private Sub CommandButton7_Click()
Dim appword As Object, wordDoku As Object, wordbereich As Object, gruppe As String
    Dim pfad As String
    Dim bereich As Range
Set bereich = ThisWorkbook.Worksheets("Telefon").Cells(1, 1).CurrentRegion
Set appword = CreateObject("Word.Application")

appword.Visible = True
Set wordDoku = appword.Documents.Add
Set wordbereich = wordDoku.Paragraphs.last.Range

gruppe = Application.InputBox(Title:="Auswahl der betroffenen Gymnastikgruppe", _
    Prompt:="Geben Sie die Nummer der Sportgruppe ein:", _
        Default:="Hier eingeben", Type:=1)
            bereich.AutoFilter Field:=5, Criteria1:=gruppe
bereich.Copy
    With wordDoku
 
Der folgende Code lässt vieles z.
Einzelne IDs mit Komma getrennt, Von Bis

Mögliche Eingaben
Code:
1,5,6,7
4 - 19
1,2,5-10
4, between 6 and 9, 13, 15-24

Visual Basic:
Sub setFilter()
    Dim gruppe As String
    Dim filters() As String
    Dim filter As String
    Dim selectedNrs() As String
    Dim i As Long, nr As Long
    Dim fromNr As Long
    Dim toNr As Long
    
    'RegExp um die Betweens abzudecken
    'Test: https://regex101.com/r/hpwI7z/1
    Static rx As Object
    If rx Is Nothing Then
        Set rx = CreateObject("VBScript.RegExp")
        rx.Pattern = "^\s*(?:(\d+)\s*-\s*(\d+)|between\s+(\d+)\s+and\s+(\d+))\s*$"
        rx.ignoreCase = True
    End If
    
    'Filter abfragen
    gruppe = Application.InputBox(Title:="Auswahl der betroffenen Gymnastikgruppe", Prompt:="Geben Sie die Nummer der Sportgruppe ein:", Default:="Hier eingeben")
    
    'Filters aufteilen
    filters = Split(gruppe, ",")
    'Die Filter durchgehen
    For i = 0 To UBound(filters)
    
        filter = filters(i)
    
        'Ist eine einfache Zahl. Also direkt diese zufürgen
        If IsNumeric(filter) Then
            pushArray selectedNrs, CStr(filter)
            
        'Ist ein Between: entwder '3-16' oder 'between 3 and 16'
        ElseIf rx.test(filter) Then
            'Von und To auslesen
            fromNr = CLng(rx.Replace(filter, "$1$3"))
            toNr = CLng(rx.Replace(filter, "$2$4"))
            'Die Liste aufstocken
            For nr = fromNr To toNr
                pushArray selectedNrs, CStr(nr)
            Next nr
        End If
    Next i
    
    'Filterarray anwenden
    Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$B$25").AutoFilter Field:=1, Criteria1:=selectedNrs, Operator:=xlFilterValues

End Sub
'/**
' * Erweitert einen Array um eins und fügt einen Inhalt hinzu
' * NewIndex = pushArray(Array, Item)
' * @param  Array       Array, der erweitert werden soll
' * @param  Variant     Neuer Wert
' * @return Long        Index des neuen Wertes
' */
Private Function pushArray(ByRef ioArray As Variant, ByVal iItem As Variant) As Long
    On Error Resume Next:   pushArray = UBound(ioArray) + 1:   On Error GoTo 0
    ReDim Preserve ioArray(pushArray):     ioArray(pushArray) = iItem
End Function
 
Ganz besonderen Danke erst mal für die Antwort. Aber sorry, das in meinen Code einzuflechten, das schaffe ich ehrlich gesagt nicht. Hätte aber auch nicht gedacht das hierfür ein so umfangreicher Code erforderlich wäre. Ich erlaube mir mal den gesamten Code von mir hier ein zu stellen. Das Problem für mich sehe ich darin, das vor und nach dem Tabellenauszug Text hinzugefügt wird. Hier sehe ich insbesondere für mich das große Problem.
Daher hoffe ich dennoch auf Unterstützung. Gruß Josef

Code:
Private Sub CommandButton7_Click()
Dim appword As Object, wordDoku As Object, wordbereich As Object, gruppe As String
    Dim pfad As String
    Dim bereich As Range
Set bereich = ThisWorkbook.Worksheets("Telefon").Cells(1, 1).CurrentRegion
Set appword = CreateObject("Word.Application")

appword.Visible = True
Set wordDoku = appword.Documents.Add
Set wordbereich = wordDoku.Paragraphs.last.Range
gruppe = Application.InputBox(Title:="Auswahl der betroffenen Gymnastikgruppe", Prompt:="Geben Sie die Nummer der Sportgruppe ein:", _
Default:="Hier eingeben", Type:=1)
bereich.AutoFilter Field:=5, Criteria1:=gruppe
bereich.Copy
    With wordDoku
        .Content.Font.Size = 15  'noch leeres Dokument formatieren
    .Content.InsertAfter "Telefonliste der Therapiegrupp Nr.:____  __.HJ 20___ " & vbLf  'schreibt den Text rein
    .Paragraphs(2).Range.Font.Size = 15     'die kopierte gefilterte Tabelle einfügen
         Set wordbereich = wordDoku.Paragraphs.last.Range
        wordbereich.Paste 'und weiter im Text
    .Content.InsertAfter vbLf & "Bitte die Liste nicht an unberechtigte weiter geben"
    .tables(1).Columns.last.Delete    'Tabelle um die letzte Spalte kürzen '.PrintOut     '.Close savechanges:=false
End With
wordbereich.Style = "kein leerraum"
bereich.AutoFilter
    appword.Application.Activate
    Set appword = Nothing
    Set bereich = Nothing
    Set wordbereich = Nothing
    Set wordDoku = Nothing
End Sub
 
Mein Code ersetzt in deinem die Frage nach dem Filtern und das Filtern selber. Der Rest bleibt so wie du ihn hast.

Versuche meinen Code zu verstehen und frage, wo Unklarheiten sind
 
Hallo, ich müsste ja in dem Beispiel von dir auf die Tabelle "Telefon" zugreifen, des weiteren in der Spalte 6 oder auch "F" den Filtersetzen. Mit dem bin ich ja schon überfordert. Dann sollte ja vor und hinter der Tabelle Text eingebracht werden. Das ist mir, glaube ich zumindest, viel zu schwer um es zu verwirklichen. Da muss ich leider passen. Danke trotzdem für dein Mühe, Gruß Josef
 
Wie bitte?
Also ein wenig Mühe. Oder einen VBA-Kurs.

In deinem Code musst du das folgende durch mein Kosntrukt ersetzen
Visual Basic:
gruppe = Application.InputBox(Title:="Auswahl der betroffenen Gymnastikgruppe", _
    Prompt:="Geben Sie die Nummer der Sportgruppe ein:", _
        Default:="Hier eingeben", Type:=1)
            bereich.AutoFilter Field:=5, Criteria1:=gruppe

Aber wenn du dein eigener Code nicht verstehst, dann liebäugle mal mit einem Kurs. Strukturiert lernt es sich besser als mit Copy&Paste.
 
Danke, habe ich hoffentlich mal richtig eingefügt wie du es erklärt hast. Ergebnis ist, das wenn ich auf den Button gehe, ein leeres Word Dokument erzeugt wird. Wenn ich aus der VBA heraus starte ebenfalls. Die Auswahl / Filtern gelingt so nicht. Es kommt kein Fehlerhinweis oder so. Gruß Josef


Code:
Private Sub CommandButton7_Click()
Dim appword As Object, wordDoku As Object, wordbereich As Object, gruppe As String
    Dim pfad As String
    Dim bereich As Range
Set bereich = ThisWorkbook.Worksheets("Telefon").Cells(1, 1).CurrentRegion
Set appword = CreateObject("Word.Application")

appword.Visible = True
Set wordDoku = appword.Documents.Add
Set wordbereich = wordDoku.Paragraphs.last.Range
' gruppe = Application.InputBox(Title:="Auswahl der betroffenen Gymnastikgruppe", Prompt:="Geben Sie die Nummer der Sportgruppe ein:", _
' Default:="Hier eingeben", Type:=1)
' bereich.AutoFilter Field:=5, Criteria1:=gruppe
End Sub
Sub setFilter()
    Dim gruppe As String
    Dim filters() As String
    Dim filter As String
    Dim selectedNrs() As String
    Dim i As Long, nr As Long
    Dim fromNr As Long
    Dim toNr As Long
   Static rx As Object
    If rx Is Nothing Then
        Set rx = CreateObject("VBScript.RegExp")
        rx.Pattern = "^\s*(?:(\d+)\s*-\s*(\d+)|between\s+(\d+)\s+and\s+(\d+))\s*$"
        rx.ignoreCase = True
    End If
  
    'Filter abfragen
   gruppe = Application.InputBox(Title:="Auswahl der betroffenen Gymnastikgruppe", Prompt:="Geben Sie die Nummer der Sportgruppe ein:", Default:="Hier eingeben")
  
    'Filters aufteilen
   filters = Split(gruppe, ",")
    'Die Filter durchgehen
   For i = 0 To UBound(filters)
  
        filter = filters(i)
  
        'Ist eine einfache Zahl. Also direkt diese zufürgen
       If IsNumeric(filter) Then
            pushArray selectedNrs, CStr(filter)
          
        'Ist ein Between: entwder '3-16' oder 'between 3 and 16'
       ElseIf rx.test(filter) Then
            'Von und To auslesen
           fromNr = CLng(rx.Replace(filter, "$1$3"))
            toNr = CLng(rx.Replace(filter, "$2$4"))
            'Die Liste aufstocken
           For nr = fromNr To toNr
                pushArray selectedNrs, CStr(nr)
            Next nr
        End If
    Next i
  
    'Filterarray anwenden
   Rows("1:1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$E$2:$E$300").AutoFilter Field:=1, Criteria1:=selectedNrs, Operator:=xlFilterValues
   
bereich.Copy
    With wordDoku
        .Content.Font.Size = 15  'noch leeres Dokument formatieren
    .Content.InsertAfter "Telefonliste der Therapiegrupp Nr.:____  __.HJ 20___ " & vbLf  'schreibt den Text rein
    .Paragraphs(2).Range.Font.Size = 15     'die kopierte gefilterte Tabelle einfügen
         Set wordbereich = wordDoku.Paragraphs.last.Range
        wordbereich.Paste 'und weiter im Text
    .Content.InsertAfter vbLf & "Bitte die Liste nicht an unberechtigte weiter geben"
    .tables(1).Columns.last.Delete    'Tabelle um die letzte Spalte kürzen '.PrintOut     '.Close savechanges:=false
End With
wordbereich.Style = "kein leerraum"
bereich.AutoFilter
    appword.Application.Activate
    Set appword = Nothing
    Set bereich = Nothing
    Set wordbereich = Nothing
    Set wordDoku = Nothing
'   End Function
End Sub

Private Function pushArray(ByRef ioArray As Variant, ByVal iItem As Variant) As Long
    On Error Resume Next:   pushArray = UBound(ioArray) + 1:   On Error GoTo 0
    ReDim Preserve ioArray(pushArray):     ioArray(pushArray) = iItem
End Function
 
Guten Morgen. Danke erst mal und folgendes zu deiner Rückfrage: Es wird ein leeres Word- Dokument erzeugt. Die Filterfrage erscheint nicht, und aufrufen tue ich es aus eine USER Form heraus, wo dann auf die Entsprechende "Tabelle" zugegriffen werden soll. Wenn erforderlich kann ich gerne eine Datei einstellen. Gruß Josef
 
Nicht nötig
Wenn die Inputbox nixht erscheint, dann rufst du setFilter() nie auf. Entweder musst du das Makro setFilter() an ein Botten binden oder du musst es von CommandButton7_Click() aufrufen.
 
Zurück