Frage zu einem Code
08.03.2014 19:35:38
Jenny
habe eine Frage zu unten stehedem Code.
Seht ihr da irgend eine Begrenzung, was die Anzahl der zu überprüfenden Zeilen in den Tabellen "Tabelle4" und "Hyperlinks" anbelangt?
Ich habe das Gefühl. dass wenn es an die 10000+ Zeilen geht, dass nicht mehr alle berücksichtigt werden. Gibt es da zum Beispiel Variablen, die nur eine gewisse Anzahl zulassen?
Wenn ja, hat jemand alternativ eine Möglichkeit, dass sagen wir mal 50.000 Zeilen pro Tabellenblatt kein Problem sind? Die Zeit, die das Makro benötigt soll dabei erstmal außer Acht gelassen werden.
Danke für Euren Rat
Jenny
Option Explicit
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
Dim strSearch2 As String
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
Set objRegEx = CreateObject("VBScript.RegExp")
With Worksheets("Hyperlinks")
For lngRow = 1 To .Cells(.Rows.Count, 2).End(xlUp).row
strSearchName = Trim$(.Cells(lngRow, 4).Value)
strSearch2 = Trim$(.Cells(lngRow, 5).Value)
If strSearchName vbNullString Then
With Worksheets("Tabelle4")
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 _
And InStr(1, objCell.Text, strSearch2) > 0 Then
If InStr(objCell.Hyperlinks.Item(1).Address, "profile.php") Then
strHyperlinkAddress = Split(objCell.Hyperlinks.Item(1).Address, "&")(0)
Else
strHyperlinkAddress = Split(objCell.Hyperlinks.Item(1).Address, "?")(0)
End If
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) ' _
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
ActiveWorkbook.Save
Application.Quit
'Shell "shutdown.exe -s -f"
End Sub
Private Sub WriteLink( _
ByVal pvstrHyperlinkAddress As String, _
ByVal pvlngRow As Long)
Dim lngColumn As Long
Dim blnFound As Boolean
With Worksheets("Hyperlinks")
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