Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1332to1336
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Bitte um Änderung von dem was ein Makro ausgibt

Bitte um Änderung von dem was ein Makro ausgibt
25.10.2013 10:23:19
dem
Hallo alle zusammen,
habe unten stehendes, soweit funktionierendes Makro, welches bestimmte Hyperlinks ausgibt, die vorher in Tabelle4 gesucht wurden.
Würde mich sehr freuen, wenn einer von euch es so abändern könnte, dass bei allen Ausgaben die letzten 32 Zeichen weggelassen werden.
Außerdem bekommt ihr das noch hin, dass da wo gegebenenfalls anpassen steht, das Active Worksheet genommen wird, damit ich nichts mehr anpassen muss in Zukunft?
Liebe Grüße
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
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 = objCell.Hyperlinks.Item(1).Address
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
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

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bitte um Änderung von dem was ein Makro ausgibt
25.10.2013 10:45:11
dem
Hallo,
Außerdem bekommt ihr das noch hin, dass da wo gegebenenfalls anpassen steht, das Active Worksheet genommen wird, damit ich nichts mehr anpassen muss in Zukunft?
Das ist die Krönung!
Ersetze einfach Worksheets("blabla") durch ActiveSheet.
le.32 Zeichen weg:
If len(pvstrHyperlinkAddress)>32 then
.Cells(pvlngRow, lngColumn).Value = left(pvstrHyperlinkAddress, len(pvstrHyperlinkAddress)-32)
Else
.Cells(pvlngRow, lngColumn).Value = pvstrHyperlinkAddress
End if

Gruß
Rudi

AW: Bitte um Änderung von dem was ein Makro ausgibt
25.10.2013 11:59:33
dem
Hallo Rudi,
du hast recht, da hätte ich selber drauf kommen können. Ich habe leider einmal das gegebenenfalls anpassen vergessen zu löschen. Die Zeile
Set objCell = Worksheets("Tabelle4").Columns(1).FindNext(objCell)
soll sich auch weiterhin auf Tabelle4 beziehen, nicht auf das ActiveSheet.
Wenn ich dann das Makro ausführe, bekomme ich die Meldung Laufzeitfehler 91: Objektvariable oder With-Blockvariable nicht festgelegt. Beim Debuggen wird dann die Zeile
Loop Until objCell.Address = strFirstAddress
gelb hinterlegt.
Ändere ich probeweise auch diese Zeile in ActiveSheet kommt keine Fehlermeldung mehr, aber das Makro liefert eben falsche Ergebnisse, eben die aus dem ActiveSheet statt aus Tabelle4.
Gruß
Jenny

Anzeige
AW: Bitte um Änderung von dem was ein Makro ausgibt
25.10.2013 12:42:17
dem
Hallo,
versuchs mal mit
Loop While Not objCell is Nothing and objCell.Address strFirstAddress
Gruß
Rudi

AW: Bitte um Änderung von dem was ein Makro ausgibt
25.10.2013 12:48:08
dem
Die Fehlermeldung ist immer noch dieselbe.

Beispielmappe!!? owT
25.10.2013 12:50:03
Rudi

AW: Beispielmappe!!? owT
25.10.2013 12:53:43
Jenny
Hallo Rudi,
ich glaube bevor ich hier anfange, sämtliche private Daten aus der Mappe zu löschen, ändere ich dann doch einfacher den Namen der Tabelle um die es geht in Hyperlinks und ändere dann hin und wieder halt die Tabelle, die diesen Namen trägt.
Ich glaub das ist bei dem Aufwand den die Bsp.-Mappe mit sich bringt das geringere Übel.
Jenny

AW: Beispielmappe!!? owT
25.10.2013 12:57:56
Jenny
Hallo Rudi,
ich glaube bevor ich hier anfange, sämtliche private Daten aus der Mappe zu löschen, ändere ich dann doch einfacher den Namen der Tabelle um die es geht in Hyperlinks und ändere dann hin und wieder halt die Tabelle, die diesen Namen trägt.
Ich glaub das ist bei dem Aufwand den die Bsp.-Mappe mit sich bringt das geringere Übel.
Jenny
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige