Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
ExcelのシートからSQLite3のCREATE TABLE句が記述されたファイルを生成するためのExcelのアドインの標準モジュールに記述するコード。
' 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment