Excel Datei filtern und in neue Datei kopieren

allo allerseits,
ich (selber nur die grundkenntnisse der grundkenntnisse) von vba suche nach einer möglichkeit eine vorhandene tabelle mit x spalten automatisch nach inhalten der spalte a zu filtern und die filterung in eine neue exceldatei zu integrieren.
es können die buchstaben A , P, E und S auftreten.
Bsp: Er soll alle Datensätze filtern die in Spalte A den Buchstaben P haben und diese Datensätze in eine neue Exceldatei kopieren.
ich weiß, dass schon mehrere themenfelder ähnlicher art im netz kursieren ich jedoch für den fall noch nicht das passende gefunden habe, dass ich mit meinem gefährlichen 1/16 Wissen auf meine wünsche anpassen könnte.
daher mein hilferuf an das VBA-Volk dadraußen, könnt ihr mir weiterhelfen ?
vielen dank im voraus und schönen samstag noch.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub FilternKopieren() Dim rngHelp As Range, rngUsedRange As Range Dim NewWB As Workbook, i%, ii% Dim ArSuche ArSuche = Array("A", "E", "P", "S") On Error GoTo ErrorHandler: Application.ScreenUpdating = False With Tabelle1 'Tabelle anpassen <<<<<<<<<<<< Set rngUsedRange = .UsedRange Set rngHelp = .UsedRange.Columns(.UsedRange.Columns.Count).Cells(1, 1) Set rngHelp = rngHelp.Offset(, 1).Resize(2) End With Set NewWB = Workbooks.Add With NewWB For i = Lbound(ArSuche) To Ubound(ArSuche) rngHelp.Cells(2, 1).FormulaR1C1 = "=RC1=""" & ArSuche(i) & """" ii = ii + 1 If .Worksheets.Count < ii Then .Worksheets.Add After:=.Worksheets(.Worksheets.Count) With .Worksheets(ii) rngUsedRange.AdvancedFilter xlFilterCopy, rngHelp, .Cells(1, 1), False End With Next i End With ErrorHandler: If Not rngHelp Is Nothing Then rngHelp.EntireColumn.Delete Application.ScreenUpdating = True If Err.Number <> 0 Then MsgBox Err.Description, _ vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _ "Error: " & Err.Number, Err.HelpFile, Err.HelpContext End If End Sub

Hallo,
vielleicht geht es so?!

Sub FilternKopieren()
Dim rngHelp As Range, rngUsedRange As Range
Dim NewWB As Workbook
Dim i%, ii%
Dim lngSuchSpalte&
Dim varFormel
Dim ArSuche


'Filter OR = Oder; AND = Und, Trennzeichen in Or/And = , (Komma) 
ArSuche = Array("OR(A,E)", "P", "S")
'Suchspalte angeben 1 = Spalte A; 2 = Spalte B usw... 
lngSuchSpalte = 1

On Error GoTo ErrorHandler:
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
With Tabelle1 'Tabelle anpassen <<<<<<<<<<<< 
    Set rngUsedRange = .UsedRange
    Set rngHelp = .UsedRange.Columns(.UsedRange.Columns.Count).Cells(1, 1)
    Set rngHelp = rngHelp.Offset(, 1).Resize(2)
End With
 

For i = Lbound(ArSuche) To Ubound(ArSuche)
    If InStr(ArSuche(i), "(") > 0 Then
        varFormel = Replace(ArSuche(i), "(", "(RC" & lngSuchSpalte & "=" & Chr(34))
        varFormel = Replace(varFormel, ",", Chr(34) & ",RC" & lngSuchSpalte & "=" & Chr(34))
        varFormel = Replace(varFormel, ")", Chr(34) & ")")
    Else
        varFormel = "RC" & lngSuchSpalte & "=" & Chr(34) & ArSuche(i) & Chr(34)
    End If
    
    rngHelp.Cells(2, 1).FormulaR1C1 = "=" & varFormel
    

    Set NewWB = Workbooks.Add
         
    With NewWB
        For ii = .Worksheets.Count To 2 Step -1
            Worksheets(ii).Delete
        Next ii
        With .Worksheets(ii)
            rngUsedRange.AdvancedFilter xlFilterCopy, rngHelp, .Cells(1, 1), False
        End With
    End With
Next i

 
ErrorHandler:
If Not rngHelp Is Nothing Then rngHelp.EntireColumn.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Excel Datei filtern und in neue Datei kopieren

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Excel Datei filtern und in neue Datei kopieren

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

310 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread