ExcelのシートからSQLite3のCREATE TABLE句が記述されたファイルを生成するためのExcelのアドインの標準モジュールに記述するコード。

Excel2SQLite3_Module.vba

' See https://pandanote.info/?p=8075 for details.
'SQLのCreate文を作る。
Option Explicit

Sub Create_CreateClause()
    Dim columnname() As Variant
    columnname = Array()
    Dim rownum As Integer
    rownum = Range(Selection.Address).Row
    Dim rightMost As Integer
    rightMost = Cells(rownum, Columns.Count).End(xlToLeft).Column
    'MsgBox rightMost
    Dim a As Integer
    For a = 1 To rightMost
        Dim s As String
        s = Trim(Cells(rownum, a).Value)
        If s <> "" Then
            ReDim Preserve columnname(UBound(columnname) + 1)
            columnname(UBound(columnname)) = s & " text"
        End If
    Next
    Write_CreateClause columnname
End Sub

'選択したCellからSQLのCreate文を作る。
Sub Create_CreateClauseFromCells()
    Dim columnname() As Variant
    columnname = Array()
    'MsgBox UBound(columnname)
    Dim r As Range
    Set r = Range(Selection.Address)
    Dim s As String
    If r.Rows.Count = 1 Then
        Dim rownum As Integer
        rownum = r.Row
        Dim a, rightMost As Integer
        rightMost = r.Column + r.Columns.Count - 1
        For a = r.Column To rightMost
            s = Trim(Cells(rownum, a).Value)
            If s <> "" Then
                ReDim Preserve columnname(UBound(columnname) + 1)
                columnname(UBound(columnname)) = s & " text"
            End If
        Next
    Else
        Dim colnum As Integer
        colnum = r.Column
        Dim lowerMost As Integer
        lowerMost = r.Row + r.Rows.Count - 1
        For a = r.Row To lowerMost
            s = Trim(Cells(a, colnum).Value)
            If s <> "" Then
                ReDim Preserve columnname(UBound(columnname) + 1)
                columnname(UBound(columnname)) = s & " text"
            End If
        Next
    End If
    Write_CreateClause columnname
End Sub

Sub Write_CreateClause(ByVal columnname As Variant)
    If UBound(columnname) < 0 Then
        MsgBox "データがないため、SQL文を作成できません。", vbExclamation
        Exit Sub
    End If
    Dim sql As String
    Dim tablename As String
    tablename = ActiveSheet.Name
    sql = "create table " & tablename & "(" & Join(columnname, ",") & ");"
    ' MsgBox sql
    Dim FileName As Variant
    FileName = Application.GetSaveAsFilename(InitialFileName:="Create_" & tablename & ".sql", FileFilter:="SQLファイル,*.sql")
    If FileName = False Then
        Exit Sub
    End If
    
    Dim objFso As Object
    Set objFso = CreateObject("Scripting.FileSystemObject")

    With objFso
        If Not .FileExists(FileName) Then
                .CreateTextFile (FileName)
        End If
        Dim byteTmp As Variant
        With CreateObject("ADODB.Stream")
            .Charset = "UTF-8"
            .Open
            .WriteText sql
            .Position = 0
            .Type = 1
            .Position = 3
            byteTmp = .Read
            .Close
            .Open
            .Write byteTmp
            .SetEOS
            .SaveToFile FileName, 2
            .Close
        End With
    End With

    Set objFso = Nothing
    MsgBox "SQLのCREATE文を作成しました。"
End Sub