Modify table borders generated by HTML macro

Skrej

Skrej

Board Regular
Joined
May 31, 2013
Messages
159
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I have some adapted macro code that generates a html table for data entered. I'd like to modify it so that blank cells don't have borders. I'm not sure how I can clarify, since I can't seem to post the actual HTML, but here's an example of the output (slightly different look in terms of cell padding, borders, etc. but it illustrates my point.)

3/14/2013 IDPA Shoot Results
​



Division, Class, and RankNameScorePDNTPEFNFT DRStage 1Stage 2Stage 3Stage 4Stage 5Stage 6
CDP Expert
Jones, Some86.6619.66222270.3(67)6(0)4(0)5.36(0)12.36(0)25.36(0)
Another, Guy161.3627.364444142.36(134)8(0)8(0)6.36(0)0(0)0(0)
ESP Sharpshoooter
Rahg, Inga49.3141.81100036.06(7.5)0(0)0(0)2(0)0(0)0(0)
Person, One220.8653.365555190.86(167.5)5(0)10(0)3(0)0(0)0(0)
Justa, Nother292.4591.456666223.45(201)12(0)12(0)15(0)0(0)0(0)
SSP Master
Dude, Steve108.9475.44111158.86(33.5)5(0)2(0)45(0)0(0)0(0)
SSP Novice
Tom, ****117.8517.353333102.85(100.5)7(0)6(0)18(0)0(0)0(0)
SSR Master
Blanke, Spaece401.99167.497777246.74(234.5)123.25(0)14(0)4(0)0(0)0(0)
SSR Novice
Try, Again319.651.68888283.25(268)16.35(0)16(0)13.25(0)0(0)0(0)

<tbody>
</tbody>

Ideas on how to remove borders from blank cells (so that only cells with data have borders)? Ideally, I'd like the Div/Class column to not have borders as well, but I could live with that column having borders as long as blank cells are border-less.

Here's the code generating the html. (I'll include both the html generating macro and the table writing macro which is called).

Code: 
Public Sub HTML_Gen()
   'adapted and modified from original HTML printing code by Dan Hall(?)
   'Get directory and name for htm file
    DocDestination = Application.GetSaveAsFilename(InitialFileName:="IDPAmatch.htm" _
                    , FileFilter:="htm Files (*.htm), *.htm")
    If DocDestination = False Then _
       GoTo CancelButton
    MsgBox "The new htm file will open in your browser."
    
    
    'Create header--------------------------------
    Open DocDestination For Output As 1
    Print #1, "" & Chr$(13)
    Print #1, "" & Chr$(13)
        'Establish Font in all areas
        Print #1, "<style type="" text="" css""="">" & Chr$(13)
            Print #1, "<!-- " & Chr$(13)
            Print #1, "BODY, TD, TR, P, H1, H2, H3  { font-family:  arial, helvetica, sans-serif; COLOR=""#000000""; font-size: 100% }"  & Chr$(13)
            Print #1, "A { COLOR=""0000FF"" }" & Chr$(13)
            Print #1, "A:hover { Color: #8F0000}" & Chr$(13)
            Print #1, " -->" & Chr$(13)
        Print #1, "</style>" & Chr$(13)
    MyTitle = " IDPA Match Results"
    Print #1, "<title>" & MyTitle & "</title>" & Chr$(13)
    Print #1, "" & Chr$(13)
    Print #1, "" & Chr$(13)
    PGTitle = Worksheets("Roster").Range("g2").Value
    Print #1, ""
    Print #1, "[h=1]<center>"; PGTitle; " IDPA Shoot Results"; "</center>[/h]"
    Print #1, "
"
   
   'Query for tables to include (check tables produced, ask for selections) -----------------------
   
   'Aquire basic table dimension info---------------------
    Dim TblRange As Range
    Dim NumShtr As Integer
        NumShtr = Worksheets("Roster").Range("g4").Value
    Dim NumStg As Integer
        NumStg = Worksheets("Roster").Range("g3").Value
    Dim StrtLn As Integer
        'StrtLn = Worksheets("Sheet5").Range("Z8").Value
    Application.ScreenUpdating = False
   
    'Check for table desired
    'Aquire specific table dimension info
    'pass info to write_tble for table creation
    
    'Summary--------------------------------------------------------
   
        Worksheets("Print").Select
        
        Dim Final As Integer
       Final = Worksheets("Print").Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
        
            Set TblRange = Worksheets("Print").Range(Cells(5, 1), Cells(Final, NumStg + 8))
         
            
        Call Write_Tbl(TblRange, DocDestination)
   
    
    
    'Create footer
    Print #1, "" & Chr$(13)
    Close
    
    'reset actve cell
    Worksheets("Print").Select
    Worksheets("Print").Range("c3").Select
    Application.ScreenUpdating = True
    
    'open htm file in browser
    ActiveWorkbook.FollowHyperlink _
    Address:=DocDestination, _
    NewWindow:=True
    
CancelButton:
   End Sub
   
Sub Write_Tbl(TblRange, DocDestination)
    
    'adapted and modified from original HTML printing code by Dan Hall(?)
    RowStart = TblRange.Row
    ColStart = TblRange.Column
    ColCount = TblRange.Columns.Count
    RowCount = TblRange.Rows.Count
    RowEnd = RowStart + RowCount - 1
    ColEnd = ColStart + ColCount - 1
    Print #1, "<center>" &  Chr$(13)
    Print #1, "
"
    While Row < RowCount
        Row = Row + 1
        DoEvents
      
        If (Not TblRange.Rows(Row).Hidden) Then
            MV = ""
            Col = 0
            While Col < ColCount
                Col = Col + 1
                CellV = ""
                If (Not TblRange.Columns(Col).Hidden) Then
                    strTemp = TblRange.Cells(Row, Col).Text
                    For intP = 1 To Len(strTemp)
                        strCC = Mid(strTemp, intP, 1)
                        If Asc(strCC) = 10 Then strCC = "
"
                        CellV = CellV & strCC
                    Next intP
                    If CellV = "" Then CellV = "
"
                    HzA = TblRange.Cells(Row, Col).HorizontalAlignment
                    CellA = " Align=Right "
                    If HzA = -4108 Then CellA = " Align=Center "
                    If HzA = -4131 Then CellA = " Align=Left "
                    If HzA = -4152 Then CellA = " Align=Right "
                    If TblRange.Cells(Row, Col).Font.Bold Then CellV = "[B]" & CellV & "[/B]"
                    If TblRange.Cells(Row, Col).Font.Italic Then CellV = "[I]" & CellV & "[/I]"
                    If HzA = 7 Or TblRange.Cells(Row, Col).MergeCells Then
                        CellA = " Align=Left "
                        ColSpan = 0
                        SameTitle = True
                        While (TblRange.Cells(Row,  Col).HorizontalAlignment = 7 Or TblRange.Cells(Row, Col).MergeCells) And  SameTitle
                            ' The following code must be changed for versions of Excel earlier than 97
                            If Not TblRange.Columns(Col).Hidden Then ColSpan = ColSpan + 1
                            Col = Col + 1
                            If (Len(TblRange.Cells(Row, Col).Text) > 1  Or TblRange.Cells(Row, Col).MergeCells = False) Then SameTitle = False:  Col = Col - 1
                        Wend
                        CellA = CellA & " ColSpan=" & ColSpan
                    End If
                    'find cell interior color
                    CC = TblRange.Cells(Row, Col).Interior.ColorIndex
                    BGC = ""
                    If CC = 1 Then BGC = "#000000" 'black"
                    If CC = 3 Or CC = 22 Then BGC = "#FFD0D0" 'Red"
                    If CC = 4 Or CC = 35 Then BGC = "#CCFFCC"  'green"
                    If CC = 6 Or CC = 19 Then BGC = "#FFFFCC" 'yellow"
                    If CC = 8 Or CC = 41 Or CC = 34 Or CC = 20 Then BGC = "#CCFFFF" 'blue
                    If CC = 9 Then BGC = "#8A0045" 'burgandy
                    If CC = 15 Or CC = 40 Then BGC = "#C0C0C0" 'grey"
                    If CC = 39 Or CC = 24 Or CC = 39 Then BGC = "#FFCCFF"  'Purple
                    If Len(BGC) > 2 Then BGC = " bgcolor=" & Chr(34) & BGC & Chr(34)
                    
                    'find cell font color
                    FC = TblRange.Cells(Row, Col).Font.ColorIndex
                    SFC1 = ""
                    SFC2 = ""
                    If FC = 3 Then
                        SFC1 = ""
                    ElseIf FC = 2 Then
                        SFC1 = ""
                    End If
                    If Len(SFC1) > 2 Then SFC2 = ""
                    'Replace chr(13) with 

                    'TblRange.Cells(Row, Col).Replace
                    
                    MV = MV & "<td" &="" cella="" bgc=""  "="">" & SFC1 & CellV & SFC2 & ""
                End If
            Wend
            Print #1, "</td">" & MV & "" & Chr$(13)
        End If
    Wend
    Print #1, "[TABLE]
<tbody>[TR]
[/TR]
</tbody>[/TABLE]
</center>" & Chr$(13)
    Print #1, "
"
    DoEvents
End Sub

Maybe rather than modifying the html table, the simpler solution would be to have code that merges non-blank cells before generating the html?

Any assistance or suggestions on what to look at are appreciated.
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Sort by date Sort by votes
You must log in or register to reply here.

Forum statistics

Threads
1,214,846
Messages
6,121,905
Members
449,054
Latest member
luca142

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top