gefilterter Import

Moin VBA-Experten,
es geht frisch in das Wochenende und für die kommenden Tage fehlt mir nur noch eine Lösung.
Ich habe zwei Arbeitsmappen
Eine Quellmappe namens Stamm mit dem relevanten Tabellenblatt Basis und meine ausgehende Mappe, mit derzeit zwei Tabellenblätter (Auswahl und Daten).
In Tabellenblatt Auswahl steht in A1 die Überschrift Liga und in A2 das Kürzel z.B. D1
Ich möchte nun per Button alle Datenzeilen aus Mappe Stamm/Blatt Basis, in meine ausgehende Mappe / Blatt Daten importieren,- allerdings nur die Daten, welche mit dem Kürzel D1 identisch sind.
Meine Quellmappe Stamm, Tabellenblatt Basis hat ebenfalls die SpaltenÜberschrift Liga, in denen sich die Kürzel befinden. (es ist die 1. Spalte)
Es soll also, vergleichbar eines erweiterten Filters, importiert werden.
Kann mir jemand das VBA schreiben oder mich auf einen Beispielcode bei Herber verweisen?
mfg
Fred

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Importieren() On Error GoTo Fehler Dim TBA, TBD, WB, TBB, Pfad$, Stammdatei$, i% Dim SP%, ZE&, LR& '*** Daten Anfang Pfad = "C:\Temp\" Stammdatei = "Stamm.xlsm" Set TBA = ThisWorkbook.Sheets("Auswahl") Set TBD = ThisWorkbook.Sheets("Daten") Set WB = Workbooks.Open(Filename:=Pfad & Stammdatei) Set TBB = WB.Sheets("Basis") SP = 1 'Spalte A ZE = 2 'ab Zeile 2 wegen Überschrift '*** Stammdaten Ende Application.ScreenUpdating = False LR = TBD.Cells(TBD.Rows.Count, SP).End(xlUp).Row TBD.Rows("2:" & LR).Delete xlUp ' reset If TBB.AutoFilterMode Then TBB.AutoFilterMode = False ' Autofilter ausschalten LR = TBB.Cells(TBB.Rows.Count, SP).End(xlUp).Row TBB.Range("$A1:$A" & LR).AutoFilter Field:=1, Criteria1:=TBA.Range("A2") TBB.Rows("2:" & LR).Copy TBD.Rows(2) WB.Close False '*** Fehlerbehandlung Err.Clear Fehler: If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub

Noch eine Prüfung eingebaut, ob überhaupt Daten für den Filter da sind.

Sub Importieren()
    On Error GoTo Fehler
    Dim TBA, TBD, WB, TBB, Pfad$, Stammdatei$
    Dim SP%, ZE&, LR&, FFilter$
    
    '*** Daten Anfang 
    Pfad = "C:\Temp\"
    Stammdatei = "Stamm.xlsm"
    
    Set TBA = ThisWorkbook.Sheets("Auswahl")
    Set TBD = ThisWorkbook.Sheets("Daten")
    Set WB = Workbooks.Open(Filename:=Pfad & Stammdatei)
    Set TBB = WB.Sheets("Basis")
    SP = 1 'Spalte A 
    ZE = 2 'ab Zeile 2 wegen Überschrift 
    '*** Stammdaten Ende 
    
    FFilter = TBA.Range("A2")
    Application.ScreenUpdating = False
    LR = TBD.Cells(TBD.Rows.Count, SP).End(xlUp).Row
    TBD.Rows("2:" & LR).Delete xlUp ' reset 
        
    If TBB.AutoFilterMode Then TBB.AutoFilterMode = False ' Autofilter ausschalten 
    LR = TBB.Cells(TBB.Rows.Count, SP).End(xlUp).Row
        
    If WorksheetFunction.CountIf(TBB.Columns(SP), FFilter) > 0 Then
        TBB.Range("$A1:$A" & LR).AutoFilter Field:=1, Criteria1:=FFilter
        TBB.Rows("2:" & LR).Copy TBD.Rows(2)
    Else
        MsgBox "Für '" & FFilter & "' keine Daten gefunden"
    End If
    WB.Close False
    '*** Fehlerbehandlung 
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

LG UweD

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

gefilterter Import

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

299 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