VBA - Import aus gefilterter, externer Datei
04.10.2018 11:15:08
RK
leider kann ich im alten Beitrag nicht mehr schreiben bzw. ich finde keine Möglichkeit.
Link:
https://www.herber.de/forum/archiv/1644to1648/t1646877.htm#1648043
@Werner
Ich hoffe du liest diesen Beitrag und kannst mir nochmals helfen.
Beispieldatei: https://www.herber.de/bbs/user/124403.zip
Im ersten Registerblatt (erstes Makro) erfolgt die Filterung auf selbigem und wird in den vorgesehen Bereich geschrieben.
Im zweiten Registerblatt (zweites Makro) werden die Daten in einer externen Datei gefiltert und sollen in das zweite Registerblatt geschrieben werden.
Allerdings gibt es zwei Probleme:
- Bei beiden Imports taucht jeweils eine Filterung doppelt auf. (finde den Fehler nicht)
- beim Import aus der externen Datei funktioniert die Zählung nicht, da die Angaben im Registerblatt 2 stehen und nicht in der externen Datei. Zwar könnte ich die Angaben in die externe Datei, allerdings empfine ich das als unsaubere Lösung. Geht es eleganter indem man die ZÄHLENWENN-Zeile modifiziert?
Über jede Hilfe bin ich sehr dankbar!
Zweites Makro:
Sub Import_Sheet_2()
Application.ScreenUpdating = False
Dim Modell As String
Dim Typ As Long
Dim loLetzte1 As Long
Dim QD, QP As String
QP = ThisWorkbook.Path & "\Source 3"
QD = Dir(QP & "\*." & "xlsx")
Set QAM = Workbooks.Open(QP & "\" & QD)
Set QRB = QAM.Sheets(1)
Set ZRB = ThisWorkbook.Sheets(2)
ZRB.Range("W2:X15").ClearContents
Model = ZRB.Range("$Z$2")
Typ = ZRB.Range("$Z$3")
loLetzte1 = QRB.Cells(QRB.Rows.Count, 16383).End(xlUp).Row
If Not Model = vbNullString Then
QRB.Range("B:J").AutoFilter Field:=1, Criteria1:="*" & Model & "*"
QRB.Range("B:J").AutoFilter Field:=9, Criteria1:=Typ
If QRB.Cells(QRB.Rows.Count, 2).End(xlUp).Row > 1 Then
QRB.AutoFilter.Range.Offset(1).Resize(QRB.AutoFilter.Range.Rows.Count - 1).Columns(4). _
SpecialCells(xlCellTypeVisible).Copy
QRB.Range("XFC2").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
QRB.AutoFilterMode = False
loLetzte1 = QRB.Cells(QRB.Rows.Count, 16383).End(xlUp).Row
QRB.Range(QRB.Cells(2, 16383), QRB.Cells(loLetzte1, 16383)).RemoveDuplicates Columns:=1, _
Header:=xlYes
loLetzte1 = QRB.Cells(QRB.Rows.Count, 16383).End(xlUp).Row
QRB.Range(QRB.Cells(2, 16384), QRB.Cells(loLetzte1, 16384)).FormulaLocal = "=ZÄ _
HLENWENNS(B:B;""*""&$Z$2&""*"";E:E;XFC2;J:J;$Z$3)"
QRB.Range(QRB.Cells(2, 16383), QRB.Cells(loLetzte1, 16384)).Copy
ZRB.Cells(2, 23).PasteSpecial Paste:=xlPasteValues
QRB.Columns("XFC:XFD").ClearContents
Else
MsgBox "Das gesuchte Modell ist nicht vorhanden."
QRB.AutoFilterMode = False
End If
Else
MsgBox "Es wurde kein Modell in Zelle Z2 angegeben."
End If
QAM.Close SaveChanges:=False
ZRB.Range("A1").Select
Application.ScreenUpdating = True
End Sub