Excel to Web Page
My stamp club decided that we needed to post our auction on the web a few days before the meeting.This macro takes the list they send me and converts into a tasteful table ready to upload to the web. I am using several loops and SELECT CASE to see if the row is Even or Odd. This combines my Excel VBA and HTML in one solution.
Sub MakeWebPage()
Dim LastCol As Long
Dim LastRow As Long
Dim TheTitle As String
Dim Quotes As String
Dim X As Long
Dim Y As Long
Dim TR, TD, eTR, ETD, clrTR
TR = " <tr class=" & Quotes & "whtrow" & Quotes & ">" 'White row
clrTR = " <tr class=" & Quotes & "contrastrow" & Quotes & ">" 'Blue Row
TD = " <td>"
ETD = " </td>"
eTR = "</tr>"
Quotes = Chr(34)
Open "C:\alan-webs\auction.htm" For Output As #1 'Name and store the file
LastCol = Application.CountA(ActiveSheet.Range("1:1")) 'Get last column
LastRow = Application.CountA(ActiveSheet.Range("A:A")) 'Get last row
Print #1, "<!DOCTYPE HTML PUBLIC " & Quotes & "-//IETF//DTD HTML//EN" _
& Quotes & ">"
Print #1, "<html>"
Print #1, "<head>"
Print #1, "<link rel=" & Quotes & "shortcut icon" & Quotes & " href=" & Quotes & "favicon.ico" _
& Quotes & ">"
' go to http://tools.dynamicdrive.com/favicon/ to make a FavIcon
Print #1, "<meta http-equiv=" & Quotes & "Content-Type" & Quotes & " content=" _
& Quotes & "text/html; charset=iso-8859-1" & Quotes & ">"
Print #1, "<style type=" & Quotes & "text/css" & Quotes & ">"
Print #1, " .contrastrow"
Print #1, " {"
Print #1, " background-color: #ddffff;" 'a bunch of HTML related stuff
Print #1, " border-bottom-style: ridge;"
Print #1, " border-bottom-width: thick;"
Print #1, " vertical-align: top;"
Print #1, " }"
Print #1, " .whtrow"
Print #1, " {"
Print #1, " border-bottom-style: ridge;"
Print #1, " border-bottom-width: thick;"
Print #1, " vertical-align: top;"
Print #1, " }"
Print #1, "</style>"
TheTitle = InputBox("What is the page Title? Date of Auction?", "Page Title", "Auction - ") 'Ask for Title
Print #1, "<title>" & TheTitle & "</title>"
Print #1, "</head>" & vbCrLf & "<body>"
Print #1, "<h1>" & TheTitle & "</h1>" ' Title on page
Print #1, "<table width=" & Quotes & "100%" & Quotes & " border=" & Quotes & "1" _
& Quotes & ">"
Print #1, " <tr>"
For Y = 1 To LastCol
Print #1, "<th>" & Cells(1, Y) & "</th>" 'Headings
Next Y
Print #1, eTR
For X = 2 To LastRow ' Rows loop
Select Case X Mod 2 'If the row is not divisible by 2 i.e. Odd
Case 1
Print #1, clrTR 'Set colored row
For Y = 1 To LastCol 'Columns loop
Print #1, TD & Cells(X, Y) & ETD
Next Y
Print #1, eTR 'end the row
Case Else
Print #1, TR 'set white row
For Y = 1 To LastCol
Print #1, TD & Cells(X, Y) & ETD 'pick up data
Next Y
Print #1, eTR 'end white row
End Select
Next X
Print #1, "</table>" 'Close the table
Print #1, "<p><a href=" & Quotes & "auction.xls" & Quotes & "
>Get spreadsheet</a></p>"
Print #1, "<p>Updated: " & Application.Text(Now(), _
"dd mmmm, yyyy HH:mm") & "</p>"
Print #1, " </body>" & vbCrLf & "</html>" 'Closing HTML stuff
Close #1
MsgBox "Done with " & LastRow & " items"
'Tell me it is done, goes so fast you need to be told
End Sub
Check out the fruits of my labor at Webster Grove Stamp Club.
|