VBA: Vergleich und Texteil suchen - Zeile kopieren

Hallo liebe Experten,
ich bräuchte mal wieder etwas Hilfe von euch.
Folgende Ausgangssituation:
Es gibt eine Adressliste. In dieser Adressliste stehen in Spalte H Nummern (es können pro Adresse mehrere Nummer in einer Zelle vorkommen - ich weiß, dass ist nicht optimal, es geht leider nicht anderst)
Im zweiten Sheet steht in B3 die zu suchende Nummer.
Beim Start des Makros soll nun die Spalte H nach der Nummer durchsucht werden. Ist eine Zelle gefunden, soll die jeweilige Zeile von Spalte B-G in das zweite Sheet (ab A7) eingefügt werden (Jeder weitere gefundene Datensatz soll dann natürlich darunter eingefügt werden)
Soweit so gut.
Das ganze wird nun durch einen Vergleich etwas erschwert.
Und zwar: Ist der gefundene Datensatz bereit im zweiten Sheet vorhanden soll dieser nicht nochmals kopiert werden.
Für ein besseres Verständnis hier eine Bsp-Datei (die aufgeführten Adressen sind frei erfunden! =) ):
https://www.herber.de/bbs/user/68977.xls
Könnt ihr mir hierbei behilflich sein?
Besten Dank schon mal.
Gruß
Joe

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Joe,
da sich die Nummern z.T. nur um einen zusätzlichen Buchstaben unterscheiden ist es etwas komplizierter und die Such-Funktion alleine reichte nicht.
Gruß
Franz

Sub NummerSuchen()
Dim vNummer As Variant, arrNummern, iI As Integer
Dim ZelleAdr As Range, ZeileFZ As Long, ZeileAdr As Long
Dim SpalteAdr As Long, SpalteFZ As Long
Dim Adresse1 As String, bVorhanden As Boolean, bIdentisch As Boolean
Dim wksAdr As Worksheet, wksFZ As Worksheet
Set wksFZ = Worksheets("Freizeit")
Set wksAdr = Worksheets("Adressen")
vNummer = wksFZ.Range("B3").Value
Set ZelleAdr = wksAdr.Columns(8).Find(what:=vNummer, LookIn:=xlValues, lookat:=xlPart)
If ZelleAdr Is Nothing Then
MsgBox "Keine Adressen zu Nummer gefunden"
Else
ZeileFZ = wksFZ.Cells(wksFZ.Rows.Count, 2).End(xlUp).Row
Adresse1 = ZelleAdr.Address
Do
ZeileAdr = ZelleAdr.Row
bVorhanden = False
'exakte Übereinstimmung der Nummern prüfen
arrNummern = Split(ZelleAdr.Value, ",")
bIdentisch = False
For iI = LBound(arrNummern) To UBound(arrNummern)
If vNummer = Trim(arrNummern(iI)) Then
bIdentisch = True
Exit For
End If
Next
If bIdentisch = True Then
If ZeileFZ = 6 Then
'noch kein Eintrag in Blatt Freizeit vorhanden
Else
'Prüfen, ob Eintrag schon vorhanden - alle 6 spalten der Zeilen identisch
For ZeileFZ = 7 To wksFZ.Cells(wksFZ.Rows.Count, 2).End(xlUp).Row
SpalteAdr = 1
bIdentisch = True
For SpalteFZ = 1 To 6
SpalteAdr = SpalteAdr + 1
If wksFZ.Cells(ZeileFZ, SpalteFZ)  wksAdr.Cells(ZeileAdr, SpalteAdr) Then
bIdentisch = False
Exit For
End If
Next
If bIdentisch = True Then
bVorhanden = True
Exit For
End If
Next
End If
If bVorhanden = False Then
ZeileFZ = wksFZ.Cells(wksFZ.Rows.Count, 2).End(xlUp).Row + 1
SpalteAdr = 1
For SpalteFZ = 1 To 6
SpalteAdr = SpalteAdr + 1
wksFZ.Cells(ZeileFZ, SpalteFZ) = wksAdr.Cells(ZeileAdr, SpalteAdr)
Next
End If
End If
Set ZelleAdr = wksAdr.Columns(8).FindNext(after:=ZelleAdr)
Loop Until ZelleAdr.Address = Adresse1
End If
End Sub

Beliebteste Forumthreads (12 Monate)

VBA: Vergleich und Texteil suchen - Zeile kopieren

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

331 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Vergleich und Texteil suchen - Zeile kopieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

331 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread