AW: Suchen und Werte übertragen von Quelle nach Ziel
09.03.2013 15:46:36
Quelle
Hallo Constantin,
hier mein Makrovorschlag.
In deiner Frage fehlt die Info, in welcher Spalte in den Quelldaten die Id-Nummer steht. Das musst du ggf. anpassen.
Auch wenn man das Grundgerüst hat (hier die Suche nur über eine ID-Nummer), so ist eine Anpassung doch immer wieder mühselig (hier die Suche über 3 Spalten + Randbedingung für Spalte 12).
Gruß
Franz
Sub DatenAbgleichen_mit_Extern()
Dim strDatei As String
Dim wbZiel As Workbook, wbQuelle As Workbook
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim bolQuelleOpen As Boolean
Dim strBerNameVorname As String, varIdNr As Variant, strAdresse1 As String
Dim ZeileZ As Long, ZeileQ As Long, Zeile As Long
Dim Zelle As Range, rngIdNrQuelle As Range
Dim arrData As Variant
Const lngSpalteLeer = 25 'Nummer der 1. leeren Spalte nach den Daten in _
der Quelltabelle, ggf. anpassen
Const lngSpaIDNrQ = 1 '1 = Spalte A, Nummer der Spalte mit den Id-Nummern in der _
Quelltabelle, ggf. anpassen
Set wbZiel = ActiveWorkbook
Set wksZiel = wbZiel.Worksheets(1)
On Error GoTo Fehler
'Quelldatei auswahlen
With Application.FileDialog(msoFileDialogOpen)
.Title = "Bitte Datei mit Quelldaten wählen"
.ButtonName = "Öffnen"
If .Show -1 Then GoTo Beenden
strDatei = .SelectedItems(1)
End With
'Prüfen, ob Quelle schon geöffnet
For Each wbQuelle In Application.Workbooks
If LCase(wbQuelle.Name) = LCase(Mid(strDatei, InStrRev(strDatei, "\") + 1)) Then
bolQuelleOpen = True
Exit For
End If
Next
If wbQuelle Is Nothing Then 'Quelle noch nicht geöffnet
'Quelldatei schreibgeschützt öffnen
bolQuelleOpen = False
Set wbQuelle = Workbooks.Open(Filename:=strDatei, ReadOnly:=True)
End If
'Tabelle1 Objektvariable zuweisen
Set wksQuelle = wbQuelle.Worksheets(1)
Application.StatusBar = "Quelldaten werden eingelesen."
With wksQuelle
'letzte Zeile mit Daten in Quelltabelle
ZeileQ = .UsedRange.Rows.Count + .UsedRange.Row - 1
'Daten ab A1 inklusive einer Leerspalte in ein Datenarray einlesen
arrData = .Range(.Cells(1, 1), .Cells(ZeileQ, lngSpalteLeer))
'Bereich, Name und Vorname in die Leerspalte des Arrays einlesen
For Zeile = 1 To ZeileQ
arrData(Zeile, lngSpalteLeer) = arrData(Zeile, 5) & "|" & arrData(Zeile, 6) _
& "|" & arrData(Zeile, 7)
Next
'Bereich mit den Id-Nummern in der Quelltabelle
Set rngIdNrQuelle = .Range(.Cells(2, lngSpaIDNrQ), .Cells(ZeileQ, lngSpaIDNrQ))
End With 'wksQuelle
Application.ScreenUpdating = False
With wksZiel
For ZeileZ = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
ZeileQ = 0 'Ergebniszeile zurücksetzen
Application.StatusBar = "Zeile Nr. " & ZeileZ & " wird bearbeitet."
'Status prüfen
If .Cells(ZeileZ, 8) = "" Then
'Id-Nummer einlesen
varIdNr = .Cells(ZeileZ, 2).Value
'Bereich,Name,Vorname einlesen
strBerNameVorname = .Cells(ZeileZ, 3) & "|" & .Cells(ZeileZ, 4) _
& "|" & .Cells(ZeileZ, 5)
If varIdNr "" Then
'Id-Nummer in Quelle suchen
Set Zelle = rngIdNrQuelle.Find(what:=varIdNr, LookIn:=xlValues, lookat:=xlWhole)
If Not Zelle Is Nothing Then
strAdresse1 = Zelle.Address '1. Fundstelle merken
Do
'Prüfen, ob Spalte 15 "F"
If arrData(Zelle.Row, 15) "F" Then
ZeileQ = Zelle.Row
Exit Do
End If
'nächsten Eintrag der Id-Nummer suchen
Set Zelle = rngIdNrQuelle.FindNext(After:=Zelle)
Loop Until Zelle.Address = strAdresse1
End If
End If 'varIdNr prüfen
If ZeileQ = 0 Then
'in Quelle nach Bereich,Name,Vorname suchen
For Zeile = LBound(arrData, 1) To UBound(arrData, 1)
If arrData(Zeile, lngSpalteLeer) = strBerNameVorname _
And arrData(Zeile, 15) "F" Then
ZeileQ = Zeile
Exit For
End If
Next Zeile
End If
'Ergebnis in Zieltabelle eintragen
If ZeileQ = 0 Then
.Cells(ZeileZ, 10) = "nicht gefunden"
Else
.Cells(ZeileZ, 10).Value = "gefunden"
.Cells(ZeileZ, 11).Value = arrData(ZeileQ, 22)
.Cells(ZeileZ, 12).Value = arrData(ZeileQ, 23)
End If
End If 'Status prüfen
Next ZeileZ
End With 'wksZiel
If bolQuelleOpen = False Then wbQuelle.Close savechanges:=False
Set wksQuelle = Nothing
Set wbQuelle = Nothing
Erase arrData
Application.ScreenUpdating = True
MsgBox "Alle Dateien eingelesen"
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
Application.ScreenUpdating = True
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
If Not wbQuelle Is Nothing And bolQuelleOpen = False Then
wbQuelle.Close savechanges:=False
End If
End Select
End With
Beenden:
Set wbZiel = Nothing
Set wbQuelle = Nothing
If IsArray(arrData) Then Erase arrData
Application.StatusBar = False
End Sub