none
Problem during generating multiple html files using vba RRS feed

  • Question

  • Hi everyone,

    I have one excel sheet which contains some data like ID,Name,Price etc. I want to generate HTML files separately for each of the IDs. For example , if I have 4 different IDs, code will generate 4 different HTML file & each of the HTML files will be saved as its corresponding ID name. Please find below some sample data.

    ID Name Order Price
    1 Difra 1 100
    2 200
    3 300
    2 Glame 1 400
    2 500
    3 600
    3 Lobee 1 700
    2 800
    3 900
    4 1000
    5 1100

    I want to create HTML files for each of the IDs and those HTML files will have the same data which I have in excel sheet in a tabular format. I/m using the following code but not sure why it's not working.

     
    Sub HTML()
    Dim row As Range
    Dim sheet As Worksheet
    Set sheet = ActiveSheet
       Values = ""
    
       Sheets("Sheet1").Range("A1").Select
    
       intLastRow = ActiveCell.SpecialCells(xlLastCell).row
    
    For j = 1 To intLastRow
        
            For i = 1 To sheet.UsedRange.Rows.Count
    If Cells(j, 1).Value <> "" And Not IsNull(Cells(j, 1).Value) Then
         
            Values = Cells(j, 1).row
        Set row = sheet.Rows(i)
        If WorksheetFunction.CountA(row) = 0 Then
             myHTML = "<HTML>"
            myHTML = myHTML & Chr(10) & "<HEAD>"
            myHTML = myHTML & Chr(10) & "<META HTTP-EQUIV=""Content-Type"" CONTENT=""text/html; charset=windows-1252"">"
            myHTML = myHTML & Chr(10) & "<META NAME=""Generator"" CONTENT=""Microsoft Word 97"">"
            myHTML = myHTML & Chr(10) & "</HEAD>"
            myHTML = myHTML & Chr(10) & "<TABLE BORDER=""5"">"
            myHTML = myHTML & Chr(10) & "<TR>"
            myHTML = myHTML & Chr(10) & "<TH COLSPAN=""5"">"
            myHTML = myHTML & Chr(10) & "<H3><BR>Test Log</H3></TH>"
            myHTML = myHTML & Chr(10) & "</TR>"
            myHTML = myHTML & Chr(10) & "<TH>" & "ID" & "</TH>"
            myHTML = myHTML & Chr(10) & "<TH>" & "Name" & "</TH>"
            myHTML = myHTML & Chr(10) & "<TH>" & "Order" & "</TH>"
            myHTML = myHTML & Chr(10) & "<TH>" & "Price" & "</TH>"
           
             For myR = Values To i - 1
                
                myHTML = myHTML & "<TR><TD>" & Worksheets("Sheet1").Cells(myR, 1).Value & "</TD><TD>" & Worksheets("Sheet1").Cells(myR, 2).Value & "</TD><TD>" & Worksheets("Sheet1").Cells(myR, 3).Value & "</TD><TD>" & Worksheets("Sheet1").Cells(myR, 4).Value & "</TD></TR>"
                
            Next myR
            myFileName = ThisWorkbook.Path & "\" & Worksheets("Sheet1").Cells(strValues, 1).Value & ".html"
            myHTML = myHTML & Chr(10) & "<FONT SIZE=2></FONT></BODY>"
            myHTML = myHTML & Chr(10) & "</HTML>"
            myHTML = Replace(myHTML, Chr(10), "</p><p>")
       
            FileNum = FreeFile
            Open myFileName For Output As #FileNum
            Print #FileNum, myHTML
            Close #FileNum
          
           
         
     End If
     
     End If
     Next i
    
    
    Next j
    End Sub

    Also, I have Upload the excel sheet for reference.

    http://1drv.ms/1eq2hzM

    Thank You.


    • Edited by Ed_Dao Friday, July 3, 2015 7:15 PM
    Friday, July 3, 2015 7:14 PM

Answers

  • Assuming that active sheet contains the data, try...

    Option Explicit

    Sub HTML()

        Dim myHTML1 As String
        Dim myHTML2 As String
        Dim myHTML3 As String
        Dim myHTMLALL As String
        Dim myName As String
        Dim myFileName As String
        Dim myR As Long
        Dim LastRow As Long
        Dim FileNum As Long
        
    '   Find the last row
        LastRow = Cells(Rows.Count, "D").End(xlUp).row
        
    '   If there's no data, exit the sub
        If LastRow = 1 Then
            MsgBox "No data was found.", vbInformation
            Exit Sub
        End If
        
    '   Build string for the first part of html code
        myHTML1 = "<HTML>"
        myHTML1 = myHTML1 & Chr(10) & "<HEAD>"
        myHTML1 = myHTML1 & Chr(10) & "<META HTTP-EQUIV=""Content-Type"" CONTENT=""text/html; charset=windows-1252"">"
        myHTML1 = myHTML1 & Chr(10) & "<META NAME=""Generator"" CONTENT=""Microsoft Word 97"">"
        myHTML1 = myHTML1 & Chr(10) & "</HEAD>"
        myHTML1 = myHTML1 & Chr(10) & "<BODY>"
        myHTML1 = myHTML1 & Chr(10) & "<TABLE BORDER=""5"">"
        myHTML1 = myHTML1 & Chr(10) & "<TR>"
        myHTML1 = myHTML1 & Chr(10) & "<TH COLSPAN=""5"">"
        myHTML1 = myHTML1 & Chr(10) & "<H3><BR>Test Log</H3></TH>"
        myHTML1 = myHTML1 & Chr(10) & "</TR>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "ID" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Name" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Order" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Price" & "</TH>"
        
    '   Build string for the last part of html code
        myHTML3 = Chr(10) & "</TABLE>"
        myHTML3 = myHTML3 & Chr(10) & "</BODY>"
        myHTML3 = myHTML3 & Chr(10) & "</HTML>"
        
    '   Create html files for each ID
        myHTML2 = ""
        For myR = 2 To LastRow + 1
            If Len(Cells(myR, "D")) > 0 Then
                If Len(Cells(myR, "B")) > 0 Then
                    myName = Cells(myR, "B").Value
                End If
                myHTML2 = myHTML2 & Chr(10) & "<TR>"
                myHTML2 = myHTML2 & Chr(10) & "<TD>" & Cells(myR, 1).Value & "</TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD>" & Cells(myR, 2).Value & "</TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD>" & Cells(myR, 3).Value & "</TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD>" & Cells(myR, 4).Value & "</TD>"
                myHTML2 = myHTML2 & Chr(10) & "</TR>"
            Else
                If Len(myHTML2) > 0 Then
                    myHTMLALL = myHTML1 & myHTML2 & myHTML3
                    myFileName = ThisWorkbook.Path & "\" & myName & ".html"
                    FileNum = FreeFile
                    Open myFileName For Output As #FileNum
                        Print #FileNum, myHTMLALL
                    Close #FileNum
                    myHTML2 = ""
                End If
            End If
        Next myR

    End Sub

    To set the font size for the table, excluding the header rows, try...

                myHTML2 = myHTML2 & Chr(10) & "<TR>"
                myHTML2 = myHTML2 & Chr(10) & "<TD><FONT SIZE=2>" & Cells(myR, 1).Value & "</FONT></TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD><FONT SIZE=2>" & Cells(myR, 2).Value & "</FONT></TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD><FONT SIZE=2>" & Cells(myR, 3).Value & "</FONT></TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD><FONT SIZE=2>" & Cells(myR, 4).Value & "</FONT></TD>"
                myHTML2 = myHTML2 & Chr(10) & "</TR>"

    Hope this helps!


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"



    • Edited by Domenic Tamburino Saturday, July 4, 2015 5:37 PM
    • Marked as answer by Ed_Dao Monday, July 6, 2015 6:41 AM
    Saturday, July 4, 2015 5:26 PM
  • In that case, try...

    Option Explicit
    
    Sub HTML()
    
        Dim myHTML1 As String
        Dim myHTML2 As String
        Dim myHTML3 As String
        Dim myHTMLALL As String
        Dim myName As String
        Dim myFileName As String
        Dim rPrice As Range
        Dim rAreas As Areas
        Dim rArea As Range
        Dim rCell As Range
        Dim RwCnt As Long
        Dim NumRows As Long
        Dim LastRow As Long
        Dim FileNum As Long
        
    '   Find the last row
        LastRow = Cells(Rows.Count, "D").End(xlUp).row
        
    '   If there's no data, exit the sub
        If LastRow = 1 Then
            MsgBox "No data was found.", vbInformation
            Exit Sub
        End If
        
    '   Build string for the first part of html code
        myHTML1 = "<HTML>"
        myHTML1 = myHTML1 & Chr(10) & "<HEAD>"
        myHTML1 = myHTML1 & Chr(10) & "<META HTTP-EQUIV=""Content-Type"" CONTENT=""text/html; charset=windows-1252"">"
        myHTML1 = myHTML1 & Chr(10) & "<META NAME=""Generator"" CONTENT=""Microsoft Word 97"">"
        myHTML1 = myHTML1 & Chr(10) & "</HEAD>"
        myHTML1 = myHTML1 & Chr(10) & "<BODY>"
        myHTML1 = myHTML1 & Chr(10) & "<TABLE BORDER=""5"">"
        myHTML1 = myHTML1 & Chr(10) & "<TR>"
        myHTML1 = myHTML1 & Chr(10) & "<TH COLSPAN=""5"">"
        myHTML1 = myHTML1 & Chr(10) & "<H3><BR>Test Log</H3></TH>"
        myHTML1 = myHTML1 & Chr(10) & "</TR>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "ID" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Name" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Order" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Price" & "</TH>"
        
    '   Build string for the last part of html code
        myHTML3 = Chr(10) & "</TABLE>"
        myHTML3 = myHTML3 & Chr(10) & "</BODY>"
        myHTML3 = myHTML3 & Chr(10) & "</HTML>"
        
    '   Assign the price range to an object variable
        Set rPrice = Range("D2:D" & LastRow)
        
    '   Assign the areas within the price range to an object variable
        If rPrice.Rows.Count = 1 Then
            Set rAreas = rPrice.Areas
        Else
            Set rAreas = rPrice.SpecialCells(xlCellTypeConstants).Areas
        End If
        
    '   Create html files for each ID
        For Each rArea In rAreas
            RwCnt = 0
            myHTML2 = ""
            NumRows = rArea.Cells.Count
            myName = rArea(1).Offset(, -2).Value
            For Each rCell In rArea.Cells
                RwCnt = RwCnt + 1
                If RwCnt = 1 Then
                    myHTML2 = myHTML2 & Chr(10) & "<TR>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD colspan=""1"" rowspan=""" & NumRows & """>" & rCell.Offset(, -3).Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD colspan=""1"" rowspan=""" & NumRows & """>" & rCell.Offset(, -2).Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD>" & rCell.Offset(, -1).Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD>" & rCell.Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "</TR>"
                Else
                    myHTML2 = myHTML2 & Chr(10) & "<TR>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD>" & rCell.Offset(, -1).Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD>" & rCell.Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "</TR>"
                End If
            Next rCell
            myHTMLALL = myHTML1 & myHTML2 & myHTML3
            myFileName = ThisWorkbook.Path & "\" & myName & ".html"
            FileNum = FreeFile
            Open myFileName For Output As #FileNum
                Print #FileNum, myHTMLALL
            Close #FileNum
        Next rArea
        
        Set rPrice = Nothing
        Set rAreas = Nothing
        Set rArea = Nothing
        Set rCell = Nothing
    
    End Sub

    Hope this helps!


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"

    • Marked as answer by Ed_Dao Monday, July 6, 2015 6:41 AM
    Sunday, July 5, 2015 8:19 PM

All replies

  • Assuming that active sheet contains the data, try...

    Option Explicit

    Sub HTML()

        Dim myHTML1 As String
        Dim myHTML2 As String
        Dim myHTML3 As String
        Dim myHTMLALL As String
        Dim myName As String
        Dim myFileName As String
        Dim myR As Long
        Dim LastRow As Long
        Dim FileNum As Long
        
    '   Find the last row
        LastRow = Cells(Rows.Count, "D").End(xlUp).row
        
    '   If there's no data, exit the sub
        If LastRow = 1 Then
            MsgBox "No data was found.", vbInformation
            Exit Sub
        End If
        
    '   Build string for the first part of html code
        myHTML1 = "<HTML>"
        myHTML1 = myHTML1 & Chr(10) & "<HEAD>"
        myHTML1 = myHTML1 & Chr(10) & "<META HTTP-EQUIV=""Content-Type"" CONTENT=""text/html; charset=windows-1252"">"
        myHTML1 = myHTML1 & Chr(10) & "<META NAME=""Generator"" CONTENT=""Microsoft Word 97"">"
        myHTML1 = myHTML1 & Chr(10) & "</HEAD>"
        myHTML1 = myHTML1 & Chr(10) & "<BODY>"
        myHTML1 = myHTML1 & Chr(10) & "<TABLE BORDER=""5"">"
        myHTML1 = myHTML1 & Chr(10) & "<TR>"
        myHTML1 = myHTML1 & Chr(10) & "<TH COLSPAN=""5"">"
        myHTML1 = myHTML1 & Chr(10) & "<H3><BR>Test Log</H3></TH>"
        myHTML1 = myHTML1 & Chr(10) & "</TR>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "ID" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Name" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Order" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Price" & "</TH>"
        
    '   Build string for the last part of html code
        myHTML3 = Chr(10) & "</TABLE>"
        myHTML3 = myHTML3 & Chr(10) & "</BODY>"
        myHTML3 = myHTML3 & Chr(10) & "</HTML>"
        
    '   Create html files for each ID
        myHTML2 = ""
        For myR = 2 To LastRow + 1
            If Len(Cells(myR, "D")) > 0 Then
                If Len(Cells(myR, "B")) > 0 Then
                    myName = Cells(myR, "B").Value
                End If
                myHTML2 = myHTML2 & Chr(10) & "<TR>"
                myHTML2 = myHTML2 & Chr(10) & "<TD>" & Cells(myR, 1).Value & "</TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD>" & Cells(myR, 2).Value & "</TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD>" & Cells(myR, 3).Value & "</TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD>" & Cells(myR, 4).Value & "</TD>"
                myHTML2 = myHTML2 & Chr(10) & "</TR>"
            Else
                If Len(myHTML2) > 0 Then
                    myHTMLALL = myHTML1 & myHTML2 & myHTML3
                    myFileName = ThisWorkbook.Path & "\" & myName & ".html"
                    FileNum = FreeFile
                    Open myFileName For Output As #FileNum
                        Print #FileNum, myHTMLALL
                    Close #FileNum
                    myHTML2 = ""
                End If
            End If
        Next myR

    End Sub

    To set the font size for the table, excluding the header rows, try...

                myHTML2 = myHTML2 & Chr(10) & "<TR>"
                myHTML2 = myHTML2 & Chr(10) & "<TD><FONT SIZE=2>" & Cells(myR, 1).Value & "</FONT></TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD><FONT SIZE=2>" & Cells(myR, 2).Value & "</FONT></TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD><FONT SIZE=2>" & Cells(myR, 3).Value & "</FONT></TD>"
                myHTML2 = myHTML2 & Chr(10) & "<TD><FONT SIZE=2>" & Cells(myR, 4).Value & "</FONT></TD>"
                myHTML2 = myHTML2 & Chr(10) & "</TR>"

    Hope this helps!


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"



    • Edited by Domenic Tamburino Saturday, July 4, 2015 5:37 PM
    • Marked as answer by Ed_Dao Monday, July 6, 2015 6:41 AM
    Saturday, July 4, 2015 5:26 PM
  • Hi Domenic,

    Thanks for your reply. By any chance can we marge ID & Name Column. ID & Name are appearing only in the first row and those column will remain same for all the rows for a particular ID. It would be better if I have them merged. The final o/p should be as follows

    1 Difra 1 100
    2 200
    3 300

    Thanks.

    Saturday, July 4, 2015 5:50 PM
  • Hi Ed,

    You say that you want the output to be as follows...

    1	Difra	1	100
    		2	200
    		3	300

    As it stands, the output should be as above.  Or do you mean that the output should be as follows?

    1	Difra	1	100
    2	Difra	2	200
    3	Difra	3	300

    Can you please clarify?


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"


    Saturday, July 4, 2015 7:51 PM
  • Hi Domenic,

    I want the output to be as follows:

    ID

    Name

    Order

    Price

    1

    Difra

    1

    100

    2

    200

    3

    300




    As ID & Name columns will have same value for all the rows, I just want to have them merged into a single cell.

    Thanks.



    • Edited by Ed_Dao Sunday, July 5, 2015 6:29 AM
    Sunday, July 5, 2015 6:25 AM
  • In that case, try...

    Option Explicit
    
    Sub HTML()
    
        Dim myHTML1 As String
        Dim myHTML2 As String
        Dim myHTML3 As String
        Dim myHTMLALL As String
        Dim myName As String
        Dim myFileName As String
        Dim rPrice As Range
        Dim rAreas As Areas
        Dim rArea As Range
        Dim rCell As Range
        Dim RwCnt As Long
        Dim NumRows As Long
        Dim LastRow As Long
        Dim FileNum As Long
        
    '   Find the last row
        LastRow = Cells(Rows.Count, "D").End(xlUp).row
        
    '   If there's no data, exit the sub
        If LastRow = 1 Then
            MsgBox "No data was found.", vbInformation
            Exit Sub
        End If
        
    '   Build string for the first part of html code
        myHTML1 = "<HTML>"
        myHTML1 = myHTML1 & Chr(10) & "<HEAD>"
        myHTML1 = myHTML1 & Chr(10) & "<META HTTP-EQUIV=""Content-Type"" CONTENT=""text/html; charset=windows-1252"">"
        myHTML1 = myHTML1 & Chr(10) & "<META NAME=""Generator"" CONTENT=""Microsoft Word 97"">"
        myHTML1 = myHTML1 & Chr(10) & "</HEAD>"
        myHTML1 = myHTML1 & Chr(10) & "<BODY>"
        myHTML1 = myHTML1 & Chr(10) & "<TABLE BORDER=""5"">"
        myHTML1 = myHTML1 & Chr(10) & "<TR>"
        myHTML1 = myHTML1 & Chr(10) & "<TH COLSPAN=""5"">"
        myHTML1 = myHTML1 & Chr(10) & "<H3><BR>Test Log</H3></TH>"
        myHTML1 = myHTML1 & Chr(10) & "</TR>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "ID" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Name" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Order" & "</TH>"
        myHTML1 = myHTML1 & Chr(10) & "<TH>" & "Price" & "</TH>"
        
    '   Build string for the last part of html code
        myHTML3 = Chr(10) & "</TABLE>"
        myHTML3 = myHTML3 & Chr(10) & "</BODY>"
        myHTML3 = myHTML3 & Chr(10) & "</HTML>"
        
    '   Assign the price range to an object variable
        Set rPrice = Range("D2:D" & LastRow)
        
    '   Assign the areas within the price range to an object variable
        If rPrice.Rows.Count = 1 Then
            Set rAreas = rPrice.Areas
        Else
            Set rAreas = rPrice.SpecialCells(xlCellTypeConstants).Areas
        End If
        
    '   Create html files for each ID
        For Each rArea In rAreas
            RwCnt = 0
            myHTML2 = ""
            NumRows = rArea.Cells.Count
            myName = rArea(1).Offset(, -2).Value
            For Each rCell In rArea.Cells
                RwCnt = RwCnt + 1
                If RwCnt = 1 Then
                    myHTML2 = myHTML2 & Chr(10) & "<TR>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD colspan=""1"" rowspan=""" & NumRows & """>" & rCell.Offset(, -3).Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD colspan=""1"" rowspan=""" & NumRows & """>" & rCell.Offset(, -2).Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD>" & rCell.Offset(, -1).Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD>" & rCell.Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "</TR>"
                Else
                    myHTML2 = myHTML2 & Chr(10) & "<TR>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD>" & rCell.Offset(, -1).Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "<TD>" & rCell.Value & "</TD>"
                    myHTML2 = myHTML2 & Chr(10) & "</TR>"
                End If
            Next rCell
            myHTMLALL = myHTML1 & myHTML2 & myHTML3
            myFileName = ThisWorkbook.Path & "\" & myName & ".html"
            FileNum = FreeFile
            Open myFileName For Output As #FileNum
                Print #FileNum, myHTMLALL
            Close #FileNum
        Next rArea
        
        Set rPrice = Nothing
        Set rAreas = Nothing
        Set rArea = Nothing
        Set rCell = Nothing
    
    End Sub

    Hope this helps!


    Domenic Tamburino Microsoft MVP - Excel xl-central.com - "For Your Microsoft Excel Solutions"

    • Marked as answer by Ed_Dao Monday, July 6, 2015 6:41 AM
    Sunday, July 5, 2015 8:19 PM