Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Bewerten Sie hier bitte das Excel-Portal

Home Zurück Vor

Download Beispiel-Arbeitsmappe

Thema

HTML-Datei aus gefilterten Daten mit Hyperlinks aufbauen

Gruppe

HTML

Problem

Wie kann ich mit dem Autofilter gefilterte Daten so in einem HTMLDatei überführen, daß auch die Hyperlinks übernommen werden?

Lösung

Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.

StandardModule: basMain

Sub Visible2HTML()
   Dim rng As Range
   Dim hyp As Hyperlink
   Dim iRow As Integer, iCol As Integer, iFile As Integer
   Dim sFile As String
   Set rng = Range("A1").CurrentRegion
   iFile = FreeFile
   sFile = Application.Path & "\testhtml.htm"
   Open sFile For Output As iFile
   Print #iFile, "<html>"
   Print #iFile, "<head>"
   Print #iFile, "<title>Bedingte HTML-Übernahme</title>"
   Print #iFile, "<style>"
   Print #iFile, "   th"
   Print #iFile, "   {"
   Print #iFile, "      font-family=tahoma,verdana;"
   Print #iFile, "      font-size=12px;"
   Print #iFile, "      font-weight=bold"
   Print #iFile, "   }"
   Print #iFile, ""
   Print #iFile, "   td"
   Print #iFile, "   {"
   Print #iFile, "      font-family=tahoma,verdana;"
   Print #iFile, "      font-size=12px;"
   Print #iFile, "   }"
   Print #iFile, "</style>"
   Print #iFile, "<head>"
   Print #iFile, "<body>"
   Print #iFile, "<table border=1 cellpadding=3 cellspacing=1>"
   Print #iFile, "  <tr>"
   For iCol = 1 To rng.Columns.Count
      Print #iFile, "    <th bgcolor=#ffffe0>" & Cells(1, iCol).Value & "</th>"
   Next iCol
   Print #iFile, "  </tr>"
   For iRow = 2 To rng.Rows.Count
      If Rows(iRow).Hidden = False Then
         Print #iFile, "  <tr>"
         For iCol = 1 To rng.Columns.Count
            If Cells(iRow, iCol).Hyperlinks.Count > 0 Then
               Set hyp = Cells(iRow, iCol).Hyperlinks(1)
            End If
            If hyp Is Nothing Then
               Print #iFile, "    <td>" & Cells(iRow, iCol).Value & "</td>"
            Else
               Print #iFile, "    <td><a href=""" & hyp.Address & """>" & Cells(iRow, iCol).Value & "</a></td>"
            End If
            Set hyp = Nothing
         Next iCol
         Print #iFile, "  </tr>"
      End If
   Next iRow
   Print #iFile, "</table>"
   Print #iFile, "</body>"
   Print #iFile, "</html>"
   Close iFile
   Shell "explorer " & sFile, vbMaximizedFocus
End Sub
Sub a()
Close
End Sub