AW: Hyperlinks E-Mail Adresse, Hyperlinks filtern
05.06.2012 08:15:51
fcs
Hallo Christian,
das ist jetzt etwas aufwendiger, da etliches berücksichtigt werden muss.
Gruß
Franz
Sub Suchen_Hyperinks()
Application.ScreenUpdating = False
Call prcSuchenHyperlink( _
wksMail:=ActiveWorkbook.Worksheets("E-Mail"), SpaMail1:=1, SpaMail2:=4, _
wksHyp:=ActiveWorkbook.Worksheets("Hyperlinks"), SpaHyp1:=1, SpaHyp2:=2)
Application.ScreenUpdating = True
' MsgBox "Fertig"
End Sub
Sub prcSuchenHyperlink(wksMail As Worksheet, SpaMail1 As Long, _
SpaMail2 As Long, wksHyp As Worksheet, SpaHyp1 As Long, SpaHyp2 As Long, _
Optional ZeileMail_1 As Long = 2, Optional ZeileHyp_1 As Long = 2)
'Sucht für Einträge ohne Hyperlink in Spalte "SpaMail1" von Blatt "wksMail" _
in Blatt "wksHyp" Spalte "SpaHyp1" den Hyperlink und überträgt diesen nach wksMail.
'Falls erforderlich werden zusätzlich die Spalten "SpaMail2" und "SpaHyp2" verglichen.
Dim strMail1 As String, strMail2 As String
Dim BereichHyp As Range, bolFound As Boolean
Dim Zelle As Range, strAdresse1 As String
Dim ZeileMail
Const bolMsgBox As Boolean = True 'False :Meldungen werden nicht angezeigt
With wksHyp
.Rows.Hidden = False
'Bereich mit den zu findenden Hyperlinks
Set BereichHyp = .Range(.Cells(ZeileHyp_1, SpaHyp1), _
.Cells(.Rows.Count, SpaHyp1).End(xlUp))
End With
With wksMail
.Rows.Hidden = False
For ZeileMail = ZeileMail_1 To .Cells(.Rows.Count, SpaMail1).End(xlUp).Row
If .Cells(ZeileMail, SpaMail1).Hyperlinks.Count = 0 _
And .Cells(ZeileMail, SpaMail1).Text "" Then
'Werte aus Spalte A und D einlesen
strMail1 = .Cells(ZeileMail, SpaMail1).Text
strMail2 = .Cells(ZeileMail, SpaMail2).Text
'Wert aus Spalte A in Hyperlink-Bereich suchen
Set Zelle = BereichHyp.Find(what:=strMail1, LookIn:=xlValues, _
lookat:=xlWhole)
If Zelle Is Nothing Then
'Eintrag nicht gefunden
If bolMsgBox = True Then
If MsgBox("Wert """ & strMail1 & """ in Zeile " & ZeileMail & " von Blatt """ _
& wksMail.Name & """ in Blatt """ & wksHyp.Name & """ nicht gefunden!", _
vbInformation + vbOKCancel, _
"Hyperlinks ergänzen - Wert nicht gefunden") = vbCancel Then Exit Sub
End If
Else
'Prüfen, ob Eintrag mehrfachvorhanden
bolFound = False
If Application.WorksheetFunction.CountIf(BereichHyp, strMail1) > 1 Then
'Eintrag mit Übereinstimmung in den beiden anderen Spalten suchen
strAdresse1 = Zelle.Address
Do
If strMail2 = wksHyp.Cells(Zelle.Row, SpaHyp2).Text Then
bolFound = True
Exit Do
End If
Set Zelle = BereichHyp.FindNext(after:=Zelle)
Loop Until Zelle.Address = strAdresse1
Else
bolFound = True
End If
If bolFound = True Then
If Zelle.Hyperlinks.Count > 0 Then
.Hyperlinks.Add Anchor:=.Cells(ZeileMail, SpaMail1), _
Address:=Zelle.Hyperlinks(1).Address, ScreenTip:=Zelle.Hyperlinks(1).Address
Else
'gefundene Zelle hat keinen Hyperlink
If bolMsgBox = True Then
If MsgBox("Zu Wert """ & strMail1 & """ gefundene Zelle in Zeile " & Zelle.Row _
& " in Blatt """ & wksHyp.Name & """ hat keinen Hyperlink", _
vbInformation + vbOKCancel, _
"Hyperlink ergänzen - gefundene Zelle hat keinen Hyperlink") _
= vbCancel Then Exit Sub
End If
End If
Else
'identischer Eintrag in 2. Spalte nicht gefunden
If bolMsgBox = True Then
If MsgBox("Wert """ & strMail1 & """ in Zeile " & ZeileMail & " von Blatt """ _
& wksMail.Name & """ ist in Blatt """ & wksHyp.Name & """ mehrfach vorhanden." _
& vbLf & vbLf & "Es wurde aber kein übereinstimmender Wert """ & strMail2 _
& """ in Spalte " & SpaHyp2 & " gefunden!", _
vbInformation + vbOKCancel, _
"Hyperlinks ergänzen - 2. Spalte nicht übereinstimend") = vbCancel Then Exit Sub
End If
End If
End If
End If
Next
End With
End Sub