Benötige Hilfe, einen Zellbezug zu ändern
29.10.2013 17:49:17
Christian
habe unten stehendes Makro, welches soweit funktioniert. Da ich aber die Arbeit mit der Arbeitsmappe etwas vereinfachen wollte, wollte ich fragen ob ihr so nett seid und mir dabei helft, dieses Makro ein wenig abzuändern.
Das Makro sucht den Text in B2 der Tabelle Hyperlinks in Spalte A der Tabelle4, wenn ein Treffer gefunden wird, wird geschaut ob ein Hyperlink bei dem Treffer hinterlegt ist und gibt die gefundenen Hyperlinks aus.
An der Ausgabe soll sich nichts ändern, jedoch an den Kriterien nach was gesucht werden soll.
Es soll in Zukunft nur noch ein Hyperlink ausgegeben werden, wenn in einer Zelle nicht nur der Wert in B2 sondern auch der Wert in C2 gefunden wird, also beide Texte in derselben Zelle.
Könnt ihr mir dabei bitte helfen?
Danke
Christian
Public Sub SearchHyperlinks()
Dim lngRow As Long
Dim objCell As Range
Dim objRegEx As Object, objMatch As Object
Dim strSearchName As String, strFoundName As String
Dim strFirstAddress As String, strHyperlinkAddress As String
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Set objRegEx = CreateObject("VBScript.RegExp")
With Worksheets("Hyperlinks") 'gegebenenfalls anpassen !!!!!!!!!!!!!!
For lngRow = 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
strSearchName = Trim$(.Cells(lngRow, 2).Value)
If strSearchName vbNullString Then
With Worksheets("Tabelle4") 'gegebenenfalls anpassen !!!!!!!!!!!!!!
Set objCell = .Columns(1).Find(What:=strSearchName, _
After:=.Cells(.Rows.Count, 1), _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
End With
If Not objCell Is Nothing Then
strFirstAddress = objCell.Address
Do
If objCell.Hyperlinks.Count 0 Then
strHyperlinkAddress = Split(objCell.Hyperlinks.Item(1).Address, "?") _
(0)
strFoundName = Trim$(objCell.Value)
If strFoundName strSearchName Then
With objRegEx
.IgnoreCase = True
.Pattern = "^" & strSearchName & " | " & strSearchName & "$" _
Set objMatch = .Execute(strFoundName)
End With
If objMatch.Count = 1 Then
If objMatch.Item(0).Value = strSearchName & " " Or _
objMatch.Item(0).Value = " " & strSearchName Then _
Call WriteLink(strHyperlinkAddress, lngRow)
End If
Else
Call WriteLink(strHyperlinkAddress, lngRow)
End If
End If
Set objCell = Worksheets("Tabelle4").Columns(1).FindNext(objCell) ' _
gegebenenfalls anpassen !!!!!!!!!!!!!!
Loop Until objCell.Address = strFirstAddress
End If
End If
Next
End With
Set objCell = Nothing
Set objMatch = Nothing
Set objRegEx = Nothing
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Private Sub WriteLink( _
ByVal pvstrHyperlinkAddress As String, _
ByVal pvlngRow As Long)
Dim lngColumn As Long
Dim blnFound As Boolean
With Worksheets("Hyperlinks") 'gegebenenfalls anpassen !!!!!!!!!!!!!!
For lngColumn = 3 To .Cells(pvlngRow, .Columns.Count).End(xlToLeft).Column
If .Cells(pvlngRow, lngColumn).Value = pvstrHyperlinkAddress Then
blnFound = True
Exit For
End If
Next
If Not blnFound Then
lngColumn = WorksheetFunction.Max(4, _
.Cells(pvlngRow, .Columns.Count).End(xlToLeft).Column + 1)
.Cells(pvlngRow, lngColumn).Value = pvstrHyperlinkAddress
End If
End With
End Sub