Excel VBA

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
 'Even though you are doing this in Excel or Access VBA, you want to write well-formed and proper HTML
    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.

Updated:	06/21/2024 07:42
This page added:	10 July 2009