Anzeige
Archiv - Navigation
1648to1652
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
Inhaltsverzeichnis

VBA - Import aus gefilterter, externer Datei

VBA - Import aus gefilterter, externer Datei
04.10.2018 11:15:08
RK
Aloha Community,
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

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

Betreff
Datum
Anwender
Anzeige
AW: VBA - Import aus gefilterter, externer Datei
04.10.2018 15:10:41
fcs
Hallo RK,
hier das angepasste Makro.
1. Beim Entfernen der Duplikate muss der Parameter "Header" geändert werden, da sonst in der 2. und letzten Zeile in Spalte W ggf. der gleiche Wert eingetragen wird.
2. In der Formel werden die Zellbezüge durch die Werte für Type und Model ersetzt
Gruß
Franz
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:=xlNo                        'xlYes in xlNo geändert !!!
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;""*" & Model & "*"";E:E;XFC2;J:J;" & Typ & ")" 'Formel angepasst
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

Anzeige
AW: VBA - Import aus gefilterter, externer Datei
05.10.2018 12:05:18
RK
Hallo Franz.
Wie konnte ich das mit dem Header übersehen? Vermutlich, da ich es schon einmal geändert hatte und für mich als abgeschlossen galt.
Aha, die Variablen direkt rein zu schreiben geht also doch. Ähnliches hatte ich probiert, funktionierte jedoch nicht, da mir die Schreibweise mit dem & nicht bekannt war.
Habe vielen Dank für deine Überarbeitung!
Dann nicht auf offen setzen. o.w.T.
05.10.2018 15:06:17
Werner

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige