HTA created table to Excel

Xlacs

New Member
Joined
Mar 31, 2021
Messages
16
Office Version
  1. 2016
Platform
  1. Windows
Hi Everyone,

Just want to seek guidance on the below code.
Basically, the tool will create a data in the table and submit it in an excel file.

Problem is, I'm not getting my desired result,

This is where the user fill up the required fill out the required fields.
1620190050566.png


Once submitted, data will be stored in the created table below.

1620190126925.png


And once user Click the add to XL button. All the data should be submitted in the Book1 Workbook.

1620190209741.png

But I'm only getting the name, grade, category, desc, and status. Not the data submitted on those fields.

Any idea?

<html>

<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
<title>XLS Data</title>
<script language="vbscript">
Sub AddRow()
Set objTable = document.getElementById("tbl1")
Set objRow = objTable.insertRow()
For intCount = 0 To 4
Set objCell = objRow.insertCell()
select case intCount
case "0"
objCell.innerHTML = document.getElementById("name").value
case "1"
objCell.innerHTML=document.getElementById("grade").value
case "2"
objCell.innerHTML = document.getElementById("company").value
case "3"
objCell.innerHTML = document.getElementById("desc").value
case "4"
objCell.innerHTML = document.getElementById("status").value
end select
Next

End Sub

Sub formReset()
document.getElementById("frm").reset()
End Sub
</script>

<script type="text/vbscript">

Sub Submit()
strFileName = "C:\Users\ChrisLacs\Desktop\Book2.xlsx"
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkbook = objExcel.Workbooks.Open(strFileName)
Set objWorksheet = objWorkbook.Worksheets(1)
Const xlCellTypeLastCell = 11
objWorksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Activate

i = 1
For Each cell In tbl1.thead.rows(0).Cells
objWorksheet.Cells(1,i).Value = cell.innerText
i = i + 1

Next
End Sub






</script>

<hta:application
applicationname="XLS Data"
border="dialog"
borderstyle="normal"
caption="Test"
contextmenu="yes"
icon=""
maximizebutton="yes"
minimizebutton="yes"
navigable="no"
scroll="no"
selection="yes"
showintaskbar="yes"
singleinstance="yes"
sysmenu="yes"
version="1.0"
windowstate="normal"
>
<style type="text/css">
body
{
background-color: white;
overflow: auto;
color: #red;
}

textarea
{
overflow: auto;
}
</style>
</head>

<body>
<form id="frm">
<div align="center"><h1>Test</h1></div>
<p>Name: <input type="text" id="name" max="20" /></p>
<p>Grade: <select id="grade">
<option value="4">4</option>
<option value="3">3</option>
<option value="2">2</option>
<option value="1">1</option>
</select>
</p>
<p>Company: <input type="text" id="company" max="50" /></p>
<p>Description: <BR><TEXTAREA NAME="desc" ROWS=5 COLS=80>Employee Description</TEXTAREA></p>
<p>Status: <BR><TEXTAREA NAME="status" ROWS=5 COLS=80>Employee status</TEXTAREA></p>
<input type="button" onclick="formReset()" value="Reset form">
</form>
<br><input type="button" value="Add Row" onclick="AddRow()">
<input id=runbutton type="button" value="Add to XL" onClick="Submit">
<table id="tbl1" width="100%" border="1">
<thead>
<tr>
<th>Name</th>
<th>Grade</th>
<th>Company</th>
<th>Description</th>
<th>Status</th>
</tr>
</thead>
</table>
</form>
</body>
</html>
VBA Code:
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
633
Office Version
  1. 365
Platform
  1. Windows
Hi. This line limits the transfer of data to the table header row:
For Each cell In tbl1.thead.rows(0).Cells
Give me some time and let me read the rest of the code to see how best to rewrite it.
 

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
633
Office Version
  1. 365
Platform
  1. Windows
Hi, the code below should work now. The only part I needed to change was this part:
VBA Code:
intRow = 1
    For Each tblRow In tbl1.Rows
        intCol = 1
        For Each cell In tblRow.Cells
            objWorksheet.Cells(intRow, intCol).value = cell.InnerText
            intCol = intCol + 1
        Next
        intRow = intRow + 1
    Next
Previously, your code would iterate through each cell of only the header row. This iterates through each row of the table (tblRow), extracting each of the cells of the row as it goes. Hope that helps.

VBA Code:
<html>

<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
<title>XLS Data</title>
<script language="vbscript">
Sub AddRow()
    Set objTable = document.GetElementById("tbl1")
    Set objRow = objTable.insertRow()
    For intCount = 0 To 4
        Set objCell = objRow.insertCell()
        Select Case intCount
            Case "0"
                objCell.innerHTML = document.GetElementById("name").value
            Case "1"
                objCell.innerHTML = document.GetElementById("grade").value
            Case "2"
                objCell.innerHTML = document.GetElementById("company").value
            Case "3"
                objCell.innerHTML = document.GetElementById("desc").value
            Case "4"
                objCell.innerHTML = document.GetElementById("status").value
        End Select
    Next
End Sub

Sub formReset()
    document.getElementById("frm").reset()
End Sub
</script>

<script type="text/vbscript">

Sub Submit()
    Dim intRow, intCol
    strFilename = "C:\Users\ChrisLacs\Desktop\Book2.xlsx"
    Set objExcel = CreateObject("Excel.Application")
    objExcel.visible = True
    Set objWorkbook = objExcel.Workbooks.Open(strFileName)
    Set objWorksheet = objWorkbook.Worksheets(1)
    Const xlCellTypeLastCell = 11
    objWorksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Activate
    
    intRow = 1
    For Each tblRow In tbl1.Rows
        intCol = 1
        For Each cell In tblRow.Cells
            objWorksheet.Cells(intRow, intCol).value = cell.InnerText
            intCol = intCol + 1
        Next
        intRow = intRow + 1
    Next
End Sub

</script>

<hta:application applicationname="XLS Data" border="dialog" borderstyle="normal" caption="Test" contextmenu="yes"
icon="" maximizebutton="yes" minimizebutton="yes" navigable="no" scroll="no" selection="yes" showintaskbar="yes"
singleinstance="yes" sysmenu="yes" version="1.0" windowstate="normal">
<style type="text/css">
body {
background-color: white;
overflow: auto;
color: #red;
}

textarea {
overflow: auto;
}
</style>
</head>

<body>
<form id="frm">
<div align="center">
<h1>Test</h1>
</div>
<p>Name: <input type="text" id="name" max="20" /></p>
<p>Grade: <select id="grade">
<option value="4">4</option>
<option value="3">3</option>
<option value="2">2</option>
<option value="1">1</option>
</select>
</p>
<p>Company: <input type="text" id="company" max="50" /></p>
<p>Description: <BR><TEXTAREA NAME="desc" ROWS=5 COLS=80>Employee Description</TEXTAREA></p>
<p>Status: <BR><TEXTAREA NAME="status" ROWS=5 COLS=80>Employee status</TEXTAREA></p>
<input type="button" onclick="formReset()" value="Reset form">
</form>
<br><input type="button" value="Add Row" onclick="AddRow()">
<input id=runbutton type="button" value="Add to XL" onClick="Submit">
<table id="tbl1" width="100%" border="1">
<thead>
<tr>
<th>Name</th>
<th>Grade</th>
<th>Company</th>
<th>Description</th>
<th>Status</th>
</tr>
</thead>
</table>
</form>
</body>

</html>
 
Solution

Xlacs

New Member
Joined
Mar 31, 2021
Messages
16
Office Version
  1. 2016
Platform
  1. Windows
You're a life saver.. Thank you so much!
 

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
633
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

No problem. Glad it's working.
 

Xlacs

New Member
Joined
Mar 31, 2021
Messages
16
Office Version
  1. 2016
Platform
  1. Windows
H
No problem. Glad it's working.
Hi Dan

Just a small problem with the code you provided.
When I try to continuously submitting the data in to the excel, all the content of the workbook has been overwritten.
It should be submitted to the next available blank cell.

Also, when submitting the data, the caption header like (Name, Grade, Company, Description, status should not be included.
Only the the data submitted within the cells.

hope to hear from you. =)
 

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
633
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Hi

Try the code below. I've tested it, and assuming that there is an existing spreadsheet with a header row (Name, Grade, etc), then this should add onto the existing data set. It should now also skip adding another header row - the solution I've used isn't particularly elegant, but it works. Let me know how it goes:

VBA Code:
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
<title>XLS Data</title>
<script language="vbscript">
Sub AddRow()
    Set objTable = document.GetElementById("tbl1")
    Set objRow = objTable.insertRow()
    For intCount = 0 To 4
        Set objCell = objRow.insertCell()
        Select Case intCount
            Case "0"
                objCell.innerHTML = document.GetElementById("name").value
            Case "1"
                objCell.innerHTML = document.GetElementById("grade").value
            Case "2"
                objCell.innerHTML = document.GetElementById("company").value
            Case "3"
                objCell.innerHTML = document.GetElementById("desc").value
            Case "4"
                objCell.innerHTML = document.GetElementById("status").value
        End Select
    Next
End Sub

Sub formReset()
    document.getElementById("frm").reset()
End Sub
</script>

<script type="text/vbscript">

Sub Submit()
    Dim intRow, intCol, blnHeaderRow
    strFilename = "C:\Users\ChrisLacs\Desktop\Book2.xlsx"
    Set objExcel = CreateObject("Excel.Application")
    objExcel.visible = True
    Set objWorkbook = objExcel.Workbooks.Open(strFileName)
    Set objWorksheet = objWorkbook.Worksheets(1)
    Const xlCellTypeLastCell = 11
    
    intRow = objWorksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
    For Each tblRow In tbl1.Rows
    if blnHeaderRow = True then 
            intCol = 1
               For Each cell In tblRow.Cells
                    objWorksheet.Cells(intRow, intCol).value = cell.InnerText
                       intCol = intCol + 1
            Next
            intRow = intRow + 1
    Else
        blnHeaderRow = True
    End if
    Next
End Sub

</script>

<hta:application applicationname="XLS Data" border="dialog" borderstyle="normal" caption="Test" contextmenu="yes"
icon="" maximizebutton="yes" minimizebutton="yes" navigable="no" scroll="no" selection="yes" showintaskbar="yes"
singleinstance="yes" sysmenu="yes" version="1.0" windowstate="normal">
<style type="text/css">
body {
background-color: white;
overflow: auto;
color: #red;
}

textarea {
overflow: auto;
}
</style>
</head>

<body>
<form id="frm">
<div align="center">
<h1>Test</h1>
</div>
<p>Name: <input type="text" id="name" max="20" /></p>
<p>Grade: <select id="grade">
<option value="4">4</option>
<option value="3">3</option>
<option value="2">2</option>
<option value="1">1</option>
</select>
</p>
<p>Company: <input type="text" id="company" max="50" /></p>
<p>Description: <BR><TEXTAREA NAME="desc" ROWS=5 COLS=80>Employee Description</TEXTAREA></p>
<p>Status: <BR><TEXTAREA NAME="status" ROWS=5 COLS=80>Employee status</TEXTAREA></p>
<input type="button" onclick="formReset()" value="Reset form">
</form>
<br><input type="button" value="Add Row" onclick="AddRow()">
<input id=runbutton type="button" value="Add to XL" onClick="Submit">
<table id="tbl1" width="100%" border="1">
<thead>
<tr>
<th>Name</th>
<th>Grade</th>
<th>Company</th>
<th>Description</th>
<th>Status</th>
</tr>
</thead>
</table>
</form>
</body>

</html>
 

Xlacs

New Member
Joined
Mar 31, 2021
Messages
16
Office Version
  1. 2016
Platform
  1. Windows
Hi Dan,

Thank your the quick response.

Unforunately, the code works but the data once transferred in excel has a big gap in rows. Hmm it doesnt move to the next blank cell.. =[
Hi

Try the code below. I've tested it, and assuming that there is an existing spreadsheet with a header row (Name, Grade, etc), then this should add onto the existing data set. It should now also skip adding another header row - the solution I've used isn't particularly elegant, but it works. Let me know how it goes:

VBA Code:
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">
<title>XLS Data</title>
<script language="vbscript">
Sub AddRow()
    Set objTable = document.GetElementById("tbl1")
    Set objRow = objTable.insertRow()
    For intCount = 0 To 4
        Set objCell = objRow.insertCell()
        Select Case intCount
            Case "0"
                objCell.innerHTML = document.GetElementById("name").value
            Case "1"
                objCell.innerHTML = document.GetElementById("grade").value
            Case "2"
                objCell.innerHTML = document.GetElementById("company").value
            Case "3"
                objCell.innerHTML = document.GetElementById("desc").value
            Case "4"
                objCell.innerHTML = document.GetElementById("status").value
        End Select
    Next
End Sub

Sub formReset()
    document.getElementById("frm").reset()
End Sub
</script>

<script type="text/vbscript">

Sub Submit()
    Dim intRow, intCol, blnHeaderRow
    strFilename = "C:\Users\ChrisLacs\Desktop\Book2.xlsx"
    Set objExcel = CreateObject("Excel.Application")
    objExcel.visible = True
    Set objWorkbook = objExcel.Workbooks.Open(strFileName)
    Set objWorksheet = objWorkbook.Worksheets(1)
    Const xlCellTypeLastCell = 11
   
    intRow = objWorksheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
    For Each tblRow In tbl1.Rows
    if blnHeaderRow = True then
            intCol = 1
               For Each cell In tblRow.Cells
                    objWorksheet.Cells(intRow, intCol).value = cell.InnerText
                       intCol = intCol + 1
            Next
            intRow = intRow + 1
    Else
        blnHeaderRow = True
    End if
    Next
End Sub

</script>

<hta:application applicationname="XLS Data" border="dialog" borderstyle="normal" caption="Test" contextmenu="yes"
icon="" maximizebutton="yes" minimizebutton="yes" navigable="no" scroll="no" selection="yes" showintaskbar="yes"
singleinstance="yes" sysmenu="yes" version="1.0" windowstate="normal">
<style type="text/css">
body {
background-color: white;
overflow: auto;
color: #red;
}

textarea {
overflow: auto;
}
</style>
</head>

<body>
<form id="frm">
<div align="center">
<h1>Test</h1>
</div>
<p>Name: <input type="text" id="name" max="20" /></p>
<p>Grade: <select id="grade">
<option value="4">4</option>
<option value="3">3</option>
<option value="2">2</option>
<option value="1">1</option>
</select>
</p>
<p>Company: <input type="text" id="company" max="50" /></p>
<p>Description: <BR><TEXTAREA NAME="desc" ROWS=5 COLS=80>Employee Description</TEXTAREA></p>
<p>Status: <BR><TEXTAREA NAME="status" ROWS=5 COLS=80>Employee status</TEXTAREA></p>
<input type="button" onclick="formReset()" value="Reset form">
</form>
<br><input type="button" value="Add Row" onclick="AddRow()">
<input id=runbutton type="button" value="Add to XL" onClick="Submit">
<table id="tbl1" width="100%" border="1">
<thead>
<tr>
<th>Name</th>
<th>Grade</th>
<th>Company</th>
<th>Description</th>
<th>Status</th>
</tr>
</thead>
</table>
</form>
</body>

</html>
 

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
633
Office Version
  1. 365
Platform
  1. Windows
Hi Dan,

Thank your the quick response.

Unforunately, the code works but the data once transferred in excel has a big gap in rows. Hmm it doesnt move to the next blank cell.. =[
I'm not sure I understand. What do you mean there is a big gap in rows?
 

Dan_W

Well-known Member
Joined
Jul 11, 2018
Messages
633
Office Version
  1. 365
Platform
  1. Windows
Hi. I just checked the HTA file - I ran it four times. Each time I ran it, I made one or two entries, and I increased the grade by one. I would then save the workbook, close the workbook, close the HTA file, and then repeat. As you can see in the BB capture below, each entry followed the next in consecutive rows. Is that not what you wanted?

MrExcel.xlsm
ABCDE
1NameGradeStatusDescription Company
2Mr Excel1Mr Excel Pty LtdThis is a description of the employeePerson status
3Ms VBA1Mr Excel Pty LtdThis is a description of the employee, VBACode status
4Ms Python2ACompetitor Pty LtdThis is a description of the employee, Python, at another company.Code status
5Great Employee A3Bad CoHere is another employee descriptionNew status
6Great Employee B3Good CoHere is another employee descriptionNew status
7Terrible Employee C4Good CoHere is another employee descriptionOld status
Sheet1
 
Last edited:

Forum statistics

Threads
1,143,692
Messages
5,720,313
Members
422,276
Latest member
streasure

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
Top