Hier mal ein möglicher Ansatz. Ungetestet. Kann sein das der eine oder andere Zähler nicht ganz hinhaut. Aber das ist ohne Testdatei fast schon normal.
Sub DateiAuswählen1()
'Deklarierung Variable
Dim Dateiname As Variant
Dim lz As Long, lq As Long, i As Long
'Workbook ist ein VBA-Objekt
Dim wbQuelle As Workbook
Dim wsQuelle As Worksheet, wsZiel As Worksheet
Dim arrQB, arrQD
Application.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
Application.Calculation = xlCalculationManual
'Öffnet Datei-Fenster um Datei auszuwählen
Dateiname = Application.GetOpenFilename(FileFilter:="Excel-Dateien(*.xls*),*.xls*")
'Prüfen ob eine Datei ausgewählt wurde
If Dateiname <> False Then
Set wbQuelle = Workbooks.Open(Filename:=Dateiname) 'Arbeitsmappe öffnen
Set wsQuelle = wbQuelle.Worksheets(1)
lq = wsQuelle.Cells(wsQuelle.Rows.Count, 2).End(xlUp).Row 'Die letzte Zeile der Spalte B bestimmen
arrQB = wsQuelle.Cells(2, 2).Resize(lq - 2) 'Werte aus Spalte b in Array
arrQD = wsQuelle.Cells(2, 4).Resize(lq - 2) 'Werte aus Spalte D in Array
wbQuelle.Close SaveChanges:=False 'Quelle schliessen
Set wsZiel = ThisWorkbook.Worksheets("Haupt")
'Zeilenwert (ab wo eingefügt werden soll) der immer wieder auf 7 zurückgesetzt _
wird, damit er wieder ab diesen Zeilenwert einfügt
lz = wsZiel.Cells(wsZiel.Rows.Count, 5).End(xlUp).Row + 1 'erste freie Zeile Spalte E
For i = LBound(arrQB) To UBound(arrQB) 'Schleife um die Zeilen des Array der Spalte B zu durchlaufen
If arrQB(i, 1) <> "" Then 'Prüfen ob etwas drinnen steht
wsZiel.Cells(lz, "E").Value = arrQB(i, 1) 'werte aus B nach E
wsZiel.Cells(lz, "F").Value = arrQD(i, 1) 'werte aus D nach F
lz = lz + 1
End If
Next i
wsZiel.UsedRange.RemoveDuplicates Columns:=5, Header:=xlYes 'Dublikate entfernen.
'es werden die unteren Doppelten entfernt. Da die neuen Werte unten stehen bleiben die Alten erhalten.
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True 'Bildschirmaktualisierung einschalten
End Sub
|