VBA Importscript soll noch sortieren

Das später folgende Script kopiert den Inhalt eines anderen Exceldokuments in die Excel Kontainerdatei. Soweit funktioniert es super :P
Nun soll das Script aber so abgeändert werden, dass der Import nicht Zeilenweise erfolgt, sondern die Zeilen in Abhändigkeit der Spalte "D3", "D4" usw. befüllt.
So steht in Spalte "D2" immer eine E-Mailadresse. Diese ist eindeutig.
Wenn nun ein Exceldokument importiert wird, das in "D2" die Mailadresse "max_mustermann@excel.org" enthält, dann soll die Importzeile in genau die Zeile der Kontainerdatei kopiert werden, wo auch "max_mustermann@excel.org" zu finden ist. So ist anfänglich die Kontainerdatei gespickt mit möglicherweise nicht vollen Zeilen und erlaubt so einen guten Überblick, welche Dateien nicht nicht importiert wurde.
Lässt sich das in dieses VBA Script integrieren? Wenn ja bitte ich um die Ergänzungen, da ich kaum VBA-Kenntnisse habe und schon ewig alles möglich versuche.

Sub Import_mit_Dialog()
Dim Ziel As Object
Dim Datei As Variant
Dim LoI As Long
Dim Loletzte As Long
Dim i  As Long
On Error GoTo Fehler
'Dialog "Datei öffnen" anzeigen
Datei = Application.GetOpenFilename("Excel-Dateien (*.xlsx), *.xlsx", , "xlsx", "Auswahl",  _
True)
'Datei = Application.GetOpenFilename("Excel-Dateien(*.xlsx),*xlsx")
'Abbrechen falls keine Datei ausgewählt
If VarType(Datei) = vbBoolean Then
MsgBox "Uups, es wurde keine Importdatei ausgewählt!", vbOKOnly + vbInformation
Else
'MsgBox "Ausgewählte Datei: " & Datei, , ""
'Ausgewählte Datei öffnen
For i = LBound(Datei) To UBound(Datei)
Workbooks.Open Filename:=Datei(i)
Set Ziel = ThisWorkbook.Worksheets(1)
Application.EnableEvents = False
With ActiveWorkbook.Worksheets(1)
Loletzte = Ziel.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
.Range("A2:" & Cells(.UsedRange.SpecialCells(xlCellTypeLastCell).Row, _
.UsedRange.SpecialCells(xlCellTypeLastCell).Column).Address).Copy Ziel. _
Cells(Loletzte, 1)
ActiveWorkbook.Close False
End With
Application.EnableEvents = True
'Speicher freigeben
Set Ziel = Nothing
Next
End If
Exit Sub
Fehler:
Application.EnableEvents = True
Set Ziel = Nothing
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Sendxp,
stehen in einer geöffneten Importdatei mehrere Datensätze mit E-Mail-Adressen in D2, D3 D4, usw. oder jeweils nur ein Datensatz?
Man kann jetzt wie folgt vorgehen:
1. Die E-Mal-Adressen in der Import-Datei werden zeilenweise abgearbeitet.
Dabei wird:
1.1 die E-Mail-Adresse aus Spalte D in eine Variable geschrieben.
1.2 in der Zieldatei wird in Spalte D nach der gemerkten E-Mailadresse gesucht.
1.3.1 Wird die E-Mail-Adresse gefunden, dann werden die Daten aus der Importdatei in die Fundzeile kopiert und überschreiben die Altdaten.
1.3.2 Wird die E-Mail-Adresse nicht gefunden, dann wird der Datensatz am Ende angefügt? oder Datensatz nicht kopiert?
Diese Programmschritte kann man relativ problemlos einbauen.
Bestätige aber nochmals, ob ich deine Beschreibung korekt verstanden hab.
Gruß
Franz

Sub Import_mit_Dialog() Dim Ziel As Worksheet Dim Datei As Variant Dim i As Integer Dim Loletzte As Long, ZeileZiel As Long Dim var_E_Mail, ZelleMail As Range Dim wkbQuelle As Workbook, wksQuelle As Worksheet On Error GoTo Fehler 'Dialog "Datei öffnen" anzeigen Datei = Application.GetOpenFilename("Excel-Dateien (*.xlsx), *.xlsx", , _ "xlsx - Bitte Datei(en) mit E-Mail-Adressdaten auswählen", "Auswahl", True) 'Datei = Application.GetOpenFilename("Excel-Dateien(*.xlsx),*xlsx") 'Abbrechen falls keine Datei ausgewählt If VarType(Datei) = vbBoolean Then MsgBox "Uups, es wurde keine Importdatei ausgewählt!", vbOKOnly + vbInformation Else Set Ziel = ThisWorkbook.Worksheets(1) 'MsgBox "Ausgewählte Datei: " & Datei, , "" 'Makrobremsen lösen With Application .EnableEvents = False .ScreenUpdating = False End With 'Ausgewählte Dateien öffnen For i = LBound(Datei) To UBound(Datei) Set wkbQuelle = Workbooks.Open(Filename:=Datei(i), ReadOnly:=True) Set wksQuelle = wkbQuelle.Worksheets(1) var_E_Mail = wksQuelle.Range("D2").Value With Ziel 'letzte Zeile mit Daten in Spalte D Loletzte = .Cells(.Rows.Count, 4).End(xlUp).Row 'E-Mail-Adresse in Spalte D suchen Set ZelleMail = .Range(.Cells(2, 4), .Cells(Loletzte, 4)) _ .Find(What:=var_E_Mail, LookIn:=xlValues, lookat:=xlWhole) 'Zielzeile bestimmen If ZelleMail Is Nothing Then ZeileZiel = Loletzte + 1 'neue E-Mail-Adresse Else ZeileZiel = ZelleMail.Row 'vorhandene E-Mail-Adresse End If End With 'Datenzeile kopieren With wksQuelle .Range(.Cells(2, 1), _ .Cells(2, .Cells(1, .Columns.Count).End(xlToLeft).Column)).Copy _ Destination:=Ziel.Cells(ZeileZiel, 1) End With wkbQuelle.Close False 'Speicher freigeben Set wkbQuelle = Nothing: Set wksQuelle = Nothing Next End If Err.Clear Fehler: 'Makrobremsen zurücksetzen With Application .EnableEvents = True .ScreenUpdating = True End With If Err.Number 0 Then MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _ & "Beschreibung: " & Err.Description, _ vbCritical, "Fehler - Makro Import_mit_Dialog" End If Set Ziel = Nothing: Set wkbQuelle = Nothing: Set wksQuelle = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

VBA Importscript soll noch sortieren

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

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread