Excelの資料の業務ツール①(フォーマット作成)

こういったものを作りたいなと思ったので作成しました。
出来上がったものとしてこんなイメージとしてはこんな感じになります。

前提として私の環境(Windows10)ではできておりますので、コードは以下を参照してください。

<html>
<head>
<meta charset="UTF-8">

<HTA:APPLICATION
    ID="HTAExcelTool"
    BORDER="dialog"
    CAPTION="yes"
    SCROLL="no"
/>

<title>Excel 可変列入力ツール</title>

<style>
body {
    font-family: Meiryo;
}

select{
    width:120px;
    height:24px;
    font-size:14px;
    color: WindowText;
    background-color: Window;
}

option{
    color: WindowText;
    background-color: Window;
}

/* 基本情報の入力欄 */
#txtFolder, #txtFile, #txtSheet {
    width:200px;
}

/* 開始列と開始行だけ幅を半分に */
#txtStartCol, #txtStartRow {
    width:100px;
}

/* Excel列用入力欄 */
#inputArea input {
    width:165px;
}

table{
    border-collapse: collapse;
    margin-top: 10px;
    border: 1px solid black;
}

td{
    padding: 4px 10px;
    border: 1px solid black;
    text-align:center;
}
</style>

<script language="VBScript">

Dim maxCols
maxCols = 10

' 初期化 Sub
Sub Init()
    Dim i, opt

    ' 列数プルダウン初期化
    Do While colSelect.options.length > 0
        colSelect.remove 0
    Loop

    For i = 1 To maxCols
        Set opt = document.createElement("OPTION")
        opt.innerText = i & " 列"
        opt.value = i
        colSelect.appendChild opt
    Next

    colSelect.value = 3

    UpdateInputs
End Sub

' Excel列入力欄描画
Sub UpdateInputs()
    Dim cols, i, html
    cols = CLng(colSelect.value)

    html = "<table><tr>"

    ' 見出し
    For i = 1 To cols
        html = html & "<td>項目" & i & "</td>"
    Next

    html = html & "</tr><tr>"

    ' 入力欄
    For i = 1 To cols
        html = html & "<td><input type='text' id='txt" & i & "'></td>"
    Next

    html = html & "</tr></table>"

    inputArea.innerHTML = html
End Sub

' Excel作成 Sub
Sub CreateExcel()
    Dim saveFolder, fileName, sheetName, fullPath
    Dim xl, wb, i, cols
    Dim startCol, startRow

    ' 基本情報取得
    saveFolder = Trim(txtFolder.value)
    fileName   = Trim(txtFile.value)
    sheetName  = Trim(txtSheet.value)
    startCol   = CLng(Trim(txtStartCol.value))
    startRow   = CLng(Trim(txtStartRow.value))
    
    If saveFolder = "" Or fileName = "" Or sheetName = "" Then
        MsgBox "格納先・ファイル名・シート名をすべて入力してください。", 48, "未入力"
        Exit Sub
    End If

    ' 拡張子補正
    If LCase(Right(fileName, 5)) <> ".xlsx" Then
        fileName = fileName & ".xlsx"
    End If

    fullPath = saveFolder & "\" & fileName

    ' Excel操作
    cols = CLng(colSelect.value)

    ' Excel起動・Workbook作成
    Set xl = CreateObject("Excel.Application")
    xl.Visible = False
    xl.DisplayAlerts = False
    Set wb = xl.Workbooks.Add()

    ' シート名変更
    wb.Sheets(1).Name = sheetName

    ' 見出し
    For i = 1 To cols
        wb.Sheets(1).Cells(startRow, startCol + i - 1).Value = "項目" & i
    Next

    ' データ
    For i = 1 To cols
        wb.Sheets(1).Cells(startRow + 1, startCol + i - 1).Value = document.getElementById("txt" & i).value
    Next

    ' 保存・終了
    wb.SaveAs fullPath
    wb.Close
    xl.Quit

    Set wb = Nothing
    Set xl = Nothing

    MsgBox "Excel 作成完了" & vbCrLf & fullPath
End Sub

</script>
</head>

<body onload="Call Init">

<h3>Excel 作成ツール</h3>
<p style="font-weight:bold; color:blue;">
  下記の入力欄に、保存先やファイル名を入力してください。
</p>

<!-- 基本情報 -->
<table>
<tr>
    <td>格納先</td>
    <td>ファイル名</td>
    <td>初回シート名</td>
    <td>開始列</td>
    <td>開始行</td>
</tr>
<tr>
    <td><input type="text" id="txtFolder" value=""></td>
    <td><input type="text" id="txtFile" value="sample.xlsx"></td>
    <td><input type="text" id="txtSheet" value="Sheet1"></td>
    <td><input type="text" id="txtStartCol" value="2"></td>
    <td><input type="text" id="txtStartRow" value="2"></td>
</tr>
</table>

<br>

<!-- 列数選択 -->
<p style="font-weight:bold; color:blue;">
  作成する Excel の表の列数を選択し、各列の項目名を入力してください。
</p>

Excelの表は何列にしますか？：
<select id="colSelect" onchange="UpdateInputs()"></select>

<div id="inputArea"></div>

<br>

<button onclick="CreateExcel()">Excel作成</button>

</body>
</html>

タイトルとURLをコピーしました