AW: Werte suchen und anderen Spaltenwert zurück geben
13.06.2009 23:00:21
Josef
Hallo Andre,
probier mal.
Sub WerteUebernehmen()
Dim objWbkZiel As Workbook, objwksZiel As Worksheet
Dim objWbkQuelle As Workbook, objwksQuelle As Worksheet
Dim objZelleQ As Range
Dim lngZeileZ As Long, lngSpalte As Long, strFirst As String
Dim varSuchen As Variant
Dim arrGefunden() As Boolean
Dim varAuswahl As Variant
Dim bolNichtgefunden As Boolean
Dim varNotgefunden As Variant
Set objWbkZiel = ActiveWorkbook
Set objwksZiel = ActiveSheet 'oder objwkbziel.worksheets(1)
With objwksZiel
'Array für gefundene Werte setzen, Wert = False
Redim arrGefunden(6 To .Cells(.Rows.Count, 1).End(xlUp).Row)
Do
'Quelldatei auswählen
varAuswahl = Application.GetOpenFilename(Filefilter:="Exceldatei, *.xls", _
Title:="Bitte Quell-Datei öffnen")
If varAuswahl = False Then Exit Do
'Quelldatei schreibgeschützt öffnen
Set objWbkQuelle = Workbooks.Open(Filename:=varAuswahl, ReadOnly:=True)
Set objwksQuelle = objWbkQuelle.Worksheets(1) '1 für die erste Tabelle die ganz links steht
'die Tabelle1 muss nicht aktive sein!!
bolNichtgefunden = False
varNichtgefunden = Null
objWbkZiel.Activate
For lngZeileZ = 6 To .Cells(.Rows.Count, 1).End(xlUp).Row
strFirst = ""
lngSpalte = 5
If arrGefunden(lngZeileZ) = False Then
varSuchen = .Cells(lngZeileZ, 1) 'Wert aus Spalte A
'Wert in Spalte B der Quelldatei suchen
Set objZelleQ = objwksQuelle.Columns(2).Find(What:=varSuchen, _
LookIn:=xlValues, lookat:=xlWhole)
If objZelleQ Is Nothing Then
'1. nicht gefundenen Wert merken
If bolNichtgefunden = False Then
bolNichtgefunden = True
varNichtgefunden = varSuchen
End If
'bei nicht gefundenen Werten #NV als Wert in Spalte E eintragen
.Cells(lngZeileZ, 5).Value = "#NV"
Else
'Wert aus Spalte F der gefundenen Zeile in Zieldatei eintragen
strFirst = objZelleQ.Address
arrGefunden(lngZeileZ) = True
Do
.Cells(lngZeileZ, lngSpalte).Value = objZelleQ.Offset(0, 4).Value
lngSpalte = lngSpalte + 1
Set objZelleQ = objwksQuelle.Columns(2).FindNext(objZelleQ)
Loop While Not objZelleQ Is Nothing And strFirst <> objZelleQ.Address
End If
End If
Next
'Quelldatei ohne speichern schliessen
objWbkQuelle.Close savechanges:=False
If bolNichtgefunden = False Then Exit Do
Loop Until MsgBox(Prompt:="Der Wert """ & varNichtgefunden & """ wurde nicht gefunden!" & _
vbLf & vbLf _
& "in anderer Datei suchen?", Buttons:=vbQuestion + vbYesNo) = vbNo
End With
'Variablen zurücksetzen
Set objWbkZiel = Nothing: Set objwksZiel = Nothing
Set objWbkQuelle = Nothing: Set objwksQuelle = Nothing
Set objZelleQ = Nothing
Redim arrGefunden(0)
End Sub
Gruß Sepp