AW: VBA: Vergleich und Texteil suchen - Zeile kopieren
09.04.2010 15:10:32
fcs
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