Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1156to1160
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

Code erweitern um Funktion

Code erweitern um Funktion
SelPa
Guten Tag !
Ich habe - dank der Hilfe aus diesem Forum hier folgenden Makro - Code zusammengebastelt. Sicher nicht alles optimal gegliedert ... aber es läuft korrekt !
Mittels diesem Makro können alle Hyperlinks in einer grossen Arbeitsmappe geprüft werden. D.h. diverse Hyperlinks liegen wild verstreut in dieser grossen Excel-Arbeitsmappe (verteilt auf unzählige Tabellenblätter und wirr durcheinander in verschiedenen Zellen und Spalten).
Private Sub CommandButton1_Click()
Dim ausgabe As Workbook, ws As Worksheet, tb As Worksheet
Dim objHL As Hyperlink, zeile As Long
zeile = 2
Set ausgabe = Workbooks.Add
Set ws = ausgabe.Sheets(1)
With ws
.Cells(1, 1) = "Tabellenblatt"
.Cells(1, 2) = "Zellenadresse"
.Cells(1, 3) = "Hyperlink"
.Cells(1, 4) = "Hyperlinkadresse"
.Cells(1, 5) = "Status"
End With
With ThisWorkbook
For Each tb In .Sheets
For Each objHL In tb.Hyperlinks
ws.Cells(zeile, 1) = tb.Name
ws.Cells(zeile, 2) = objHL.Range.Address(0, 0)
ws.Cells(zeile, 3) = objHL.TextToDisplay
ws.Cells(zeile, 4) = objHL.Address
If InternetCheckConnection(objHL.Address, FIFC, 0&) = 0 Then
ws.Cells(zeile, 5) = "Fehlerhaft"
Else
ws.Cells(zeile, 5) = "OK"
End If
zeile = zeile + 1
Next
Next
End With
ws.Columns.AutoFit
ausgabe.Activate
'Formatieren der Ausgabe-Liste:
ws.Rows("1:1").Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
ws.Columns("C:C").Select
Selection.ColumnWidth = 120
ws.Cells.Select
ws.Range("C1").Activate
Selection.AutoFilter
ws.Range("C11").Select
ActiveWindow.SmallScroll ToRight:=4
Selection.AutoFilter Field:=5, Criteria1:="Fehlerhaft"
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.787401575)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.984251969)
.BottomMargin = Application.InchesToPoints(0.984251969)
.HeaderMargin = Application.InchesToPoints(0.4921259845)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 2
.PrintErrors = xlPrintErrorsDisplayed
End With
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "Fehlerhafte Hyperlinks in der Wissensdatenbank SC SW"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = "Stand: &D"
.LeftMargin = Application.InchesToPoints(0.787401575)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.984251969)
.BottomMargin = Application.InchesToPoints(0.984251969)
.HeaderMargin = Application.InchesToPoints(0.4921259845)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA3
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 2
.PrintErrors = xlPrintErrorsDisplayed
End With
ws.Range("A1").Select
End Sub

Der Code soll nun so erweitert / ergänzt werden, dass Hyperlinks, welche auf andere Stellen innerhalb dieser Arbeitsmappe führen - nicht als Fehler ausgegeben werden.
D.h. ich habe in meiner grossen Arbeitsmappe u.a. Hyperlinks welche bloss auf ein anderer Tabellenblatt führen, nicht aber ins Intranet, Sharepoint oder Internet ...
un diese Links sollen niemals als FEHLERHAFT ausgegeben werden.
Sie dienen ja bloss als Dokument-interne Sprung-Links
Wer kann mir dabei helfen ?
Hoffe, meine Frage war so einigermassen verständlich
Im voraus besten Dank !

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Code erweitern um Funktion
27.05.2010 15:47:58
Rudi
Hallo,
versuchs mal so:
        If InternetCheckConnection(objHL.Address, FIFC, 0&) = 0 Then
If objHL.Address  "" Then
ws.Cells(zeile, 5) = "Fehlerhaft"
End If
Else
ws.Cells(zeile, 5) = "OK"
End If

Gruß
Rudi
AW: Code erweitern um Funktion
27.05.2010 16:30:00
SelPa
Genau was ich suchte und brauche :-)
HERZLICHEN DANK !!!!
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige