Code mit "find"

Question

Hallo,

habe folgenden Code, der mir für jeden passenden Namen+Vornamen aus einem anderen Tabellenblatt eine diesem Namenpaar entsprechende Nr. zuordnen soll.
Klapp soweit, bis auf die Datensätze, wo der Namen mehrfach zu verschiedenen Vornamen vorkommt. Hier wird eine falsche Nr. zugewiesen. Ich habe Inder Testdatei solch einen Fehler zur besseren Verdeutlichung einmal farbig markiert.
Wir kann ich den bestehenden Code modifizieren, damit die Zuordnung eindeutig wird?
Sub DatAkt()
'
' Übernahme der M-Nr

Sheets("M-Nr").Select

Dim rng As Range, rng1 As Range
Dim iRow As Integer
iRow = 2
Do Until IsEmpty(Cells(iRow, 1))


Set rng = Sheets("Daten").Columns(1).Find( _
what:=Cells(iRow, 3), lookat:=xlWhole, LookIn:=xlValues)
Set rng1 = Sheets("Daten").Columns(2).Find( _
what:=Cells(iRow, 4), lookat:=xlWhole, LookIn:=xlValues)


If Not rng Is Nothing And Not rng1 Is Nothing Then
Range(rng.Offset(0, 4), rng.Offset(0, 4)).Value = _
Cells(iRow, 1).Value


End If
Sheets("M-Nr").Select
iRow = iRow + 1
Loop

End Sub


http://www.file-upload.net/download-8799247/TestZuordnung.xlsm.html

Gruß
Andreas

Answer 1

Hi Andreas,

benutze doch mal einen anderen Upload-Agent - z.B. Dropbox bietet sich da an (ist eine Art eigener "Webspace" im Internet)

Bis später,
Karin

Answer 2

hi Andreas ^^

iRow = iRow + 1 mit else verknuepfen

if blah blah then

blah blah

else
iRow = iRow + 1
end if

nutze im vbeditor die Haltepunkte um variablen zu überprüfen

deine var erhöhte sich bei fund und nichtfund,die else structur ermöglicht dir auf nichtfund zu reagieren und dann die var um 1 zu erhöhen,somit werden xxx Daten erfasst

gruss nighty

Answer 3

hi all ^^

bei wiederholter suche ist nun wahrscheinlich eine endlosschleife entstanden,wenn es so sein sollte,musst du den suchbereich der mit rng definiert ist ,mit einer seperaten var verkuerzen

gruss nighty

Answer 4

Hallo nighty,

ich habe alle Vorschläge eingearbeitet. Zur besseren Übersicht hier noch mal der vollständige Code. Nur leider wird ds Problem immer noch nicht richtig gelöst. Es fehlen die Zuordnungen/Einträge in den Fällen, in denen der Nachname mehrfach vorkommt..?
Sub DatAkt()
'
' Übernahme der M-Nr

Sheets("M-Nr").Select

Dim rng As Range, rng1 As Range
Dim iRow As Integer
iRow = 2
Do Until IsEmpty(Cells(iRow, 1))


Set rng = Sheets("Daten").Columns(1).Find( _
what:=Cells(iRow, 3), lookat:=xlWhole, LookIn:=xlValues)
Set rng1 = Sheets("Daten").Columns(2).Find( _
what:=Cells(iRow, 4), lookat:=xlWhole, LookIn:=xlValues)


If Not rng Is Nothing And Not rng1 Is Nothing Then
If rng.Row = rng1.Row Then

Range(rng.Offset(0, 4), rng.Offset(0, 4)).Value = _
Cells(iRow, 1).Value
Else
iRow = iRow + 1

End If
End If

Sheets("M-Nr").Select
iRow = iRow + 1
Loop

End Sub

Gruß
Andreas

Answer 5

hi andreas ^^

etwas in der art ?

gruss nighty

Sub DatAkt()
Worksheets("M-Nr").Select
Dim rng As Range, rng1 As Range
Dim iRow As Integer, iRow2 As Integer
Dim icolum1 As Long, icolum2 As Long
iRow = 2
iRow2 = 2
icolum1 = Worksheets("Daten").Cells(Rows.Count, 1).End(xlUp).Row
icolum2 = Worksheets("Daten").Cells(Rows.Count, 2).End(xlUp).Row
Do Until IsEmpty(Cells(iRow, 1))
Set rng = Worksheets("Daten").Range(Cells(iRow2, 1), Cells(icolum1, 1)).Find( _
what:=Cells(iRow, 3), lookat:=xlWhole, LookIn:=xlValues)
Set rng1 = Worksheets("Daten").Range(Cells(iRow2, 2), Cells(icolum2, 2)).Find( _
what:=Cells(iRow, 4), lookat:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing And Not rng1 Is Nothing And rng.Row = rng1.Row Then
Range(rng.Offset(0, 4), rng.Offset(0, 4)).Value = _
Cells(iRow, 1).Value
iRow2 = rng.Row + 1
Else
iRow = iRow + 1
iRow2 = 2
End If
Sheets("M-Nr").Select
Loop
End Sub

p.s.
nicht getestet ^^

Answer 6

hi all ^^

ich kann xlsx auch nicht lesen,das ist erschwerend ^^

karin hatte ja eine möglichkeit benannt die Datei hochzuladen

eventuell ist ihre lösung auch nachvollziehbarer fuer dich

gruss nighty

Answer 7

Hallo nighty,

der Code hängt sich auf bei " set rng...., leider.

Ich komme aber noch mal auf meine Ausgangsformel, die solange gut funktioniert, wie es nur einen Nachnamen gibt.
Ich kenne mich zu wenig in der Syntax aus, um diesen Code um eine 2. Spalte zu erweitern:

aus:
Set rng = Sheets("Daten").Columns(8).Find( _
what:=Cells(iRow, 6), lookat:=xlWhole, LookIn:=xlValues)


wird....wenn das so gehen würde...
Set rng = Sheets("Daten").Columns(8) + Columns(9).Find( _
what:=Cells(iRow, 6)+(iRow,7) , lookat:=xlWhole, LookIn:=xlValues)

Gruß
Andreas

Answer 8

Hallo,

hier ein link zur Testdatei in der Dropbox:
https://dl.dropboxusercontent.com/u/43993843/Mappe2.xls

Answer 9

Hi,

das geht mit folgendem Code:

Sub Uebergabe()
Dim iRow
Dim lngLetzte As Long
Dim rng As Range
Dim strStart As String
lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
For iRow = 2 To lngLetzte
Set rng = Sheets("M-Nr").Columns(3).Find( _
what:=Cells(iRow, 1), lookat:=xlWhole, LookIn:=xlValues)
If Not rng Is Nothing Then
strStart = rng.Address
Do
If rng.Offset(0, 1) = Cells(iRow, 1).Offset(0, 1) Then
Cells(iRow, 5) = rng.Offset(0, -2).Value
End If
Set rng = Sheets("M-Nr").Columns(3).FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> strStart
End If
Set rng = Nothing
Next iRow
End Sub

Deine Daten in Spalte 4, die du von Hand eingetragen hast, sind teilweise falsch. Hier mal die Gegenüberstellung - links deine und rechts die mit dem Code ausgelesenen:

--- | ---
322 | 322
323 | 323
378 | ---
--- | 378
373 | 373
--- | ---
--- | ---
319 | 319
356 | 365
--- | 355
--- | 356
419 | 419
350 | 350

die ich auch von Hand vergleichen habe.

Bis später,
Karin

Answer 10

Hi Karin,

danke!! Die bisherigen Daten in Spalte 4 waren das noch falsche Ergebnis des anderen Codes. Dein Code funktioniert einwandfrei und hat mein eigentliches Problem auch gelöst - super. Allerdings bin ich (noch) nicht ganz dahinter gekommen, wie du das eigentlich machst...Ich werde mir das noch mal Schritt für Schritt ansehen müssen.

Es wäre aber trotzdem noch prima, wenn du mir zu meiner Frage aus Nr.17 unseres Chats noch helfen könntest hinsichtlich der Syntax - nur interessenhalber...
Viele Grüße
Andreas

P.S: danke auch an nighty!!