VBA – ページ 3 – テックメモ

2020-10-302021-07-03

VBA 起動部分テンプレート

いつも忘れてしまうのでメモ。

右クリックメニューの階層化。高速化等々。

Dim caption As String

Sub auto_open()

On Error Resume Next

caption = "会員検索フォーム"

For i = 1 To 3
  Application.CommandBars("cell").Controls(caption).Delete
Next

With Application.CommandBars("cell").Controls.Add
  .OnAction = "show_form"
  .caption = caption
End With

Call show_form

'With Application.CommandBars("cell").Controls.Add(Type:=msoControlPopup)
'  .caption = "メニュー"
'  With .Controls.Add(Type:=msoControlButton)
'  .caption = "アイテム"
'  .OnAction = "show_form"
'  End With
'End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 3
  Application.CommandBars("cell").Controls(caption).Delete
Next

' Application.CommandBars("cell").Controls("メニュー").Delete

End Sub

Sub Initialize()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual ' 関数利用注意
    
End Sub

Sub Finalize()

Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
    
End Sub

Dim caption As String

Sub auto_open()

On Error Resume Next

caption = "会員検索フォーム"

For i = 1 To 3

Application.CommandBars("cell").Controls(caption).Delete

With Application.CommandBars("cell").Controls.Add

.OnAction = "show_form"

.caption = caption

End With

Call show_form

'With Application.CommandBars("cell").Controls.Add(Type:=msoControlPopup)

' .caption = "メニュー"

' With .Controls.Add(Type:=msoControlButton)

' .caption = "アイテム"

' .OnAction = "show_form"

' End With

'End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 3

Application.CommandBars("cell").Controls(caption).Delete

' Application.CommandBars("cell").Controls("メニュー").Delete

End Sub

Sub Initialize()

Application.ScreenUpdating = False

Application.EnableEvents = False

Application.DisplayAlerts = False

Application.Calculation = xlCalculationManual ' 関数利用注意

End Sub

Sub Finalize()

Application.Calculation = xlCalculationAutomatic

Application.DisplayAlerts = True

Application.EnableEvents = True

Application.ScreenUpdating = True

End Sub

2020-09-092025-12-03

VBA 並び替え(Sort)

いつも忘れてしまうので。

Sub test()

Set w = Sheets("Sheet1")

With w.Sort

' 条件設定

' SortFields.Add2はExcel2013までエラーになる

.SortFields.Clear
.SortFields.Add _
  Key:=w.Range("A1"), _
  SortOn:=xlSortOnValues, _
  Order:=xlAscending
  
' ●Key (並び替え基準セル/必須)

' ●SortOn (並び替えタイプ)
' xlSortOnValues : データ/既定
' xlSortOnCellColor : 背景色
' xlSortOnFontColor : 文字色
' xlSortOnIcon : アイコン

' ●Order (並び替え順序)
' xlAscending : 昇順/既定
' xlDescending : 降順

' ●CustomOrder (ユーザー設定の基準)
' 文字列で基準を指定する

' ●DataOption (数値と文字列の基準)
' xlSortNormal : 数値と文字列を別々/既定
' xlSortTextAsNumbers : 文字列を数値と見なす

' 実行

.SetRange w.Cells(1, 1).CurrentRegion
.Header = xlYes
.MatchCase = True
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply

' ●Header (1行目がタイトル行か)
' xlGuess : 自動判定
' xlYes : 1行目はタイトル
' xlNo : 1行目はタイトルではない/既定

' ●MatchCase (大文字と小文字を区別するか)
' True : 区別する
' False : 区別しない/既定

' ●Orientation (並べ替えの方向)
' xlTopToBottom : 上下/既定
' xlLeftToRight : 左右

' ●SortMethod (ふりがなを使うかどうか)
' xlPinYin : ふりがなで並び替え/既定
' xlStroke : 文字コードで並び替え

End With

End Sub

Sub test()

Set w = Sheets("Sheet1")

With w.Sort

' 条件設定

' SortFields.Add2はExcel2013までエラーになる

.SortFields.Clear

.SortFields.Add _

Key:=w.Range("A1"), _

SortOn:=xlSortOnValues, _

Order:=xlAscending

' ●Key (並び替え基準セル/必須)

' ●SortOn (並び替えタイプ)

' xlSortOnValues : データ/既定

' xlSortOnCellColor : 背景色

' xlSortOnFontColor : 文字色

' xlSortOnIcon : アイコン

' ●Order (並び替え順序)

' xlAscending : 昇順/既定

' xlDescending : 降順

' ●CustomOrder (ユーザー設定の基準)

' 文字列で基準を指定する

' ●DataOption (数値と文字列の基準)

' xlSortNormal : 数値と文字列を別々/既定

' xlSortTextAsNumbers : 文字列を数値と見なす

' 実行

.SetRange w.Cells(1, 1).CurrentRegion

.Header = xlYes

.MatchCase = True

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

' ●Header (1行目がタイトル行か)

' xlGuess : 自動判定

' xlYes : 1行目はタイトル

' xlNo : 1行目はタイトルではない/既定

' ●MatchCase (大文字と小文字を区別するか)

' True : 区別する

' False : 区別しない/既定

' ●Orientation (並べ替えの方向)

' xlTopToBottom : 上下/既定

' xlLeftToRight : 左右

' ●SortMethod (ふりがなを使うかどうか)

' xlPinYin : ふりがなで並び替え/既定

' xlStroke : 文字コードで並び替え

End With

End Sub

ダイアログを表示させ、実行は手動にする場合。

Sub test()

Set w = Sheets("Sheet1")

w.Range("A1:B7").Select ' 先に選択しておかないとSetRangeが適用されない

With w.Sort
  .SortFields.Clear
  .SortFields.Add Key:=w.Range("B1") ' 選択範囲外だと空白になる
  .SetRange Selection
  .Header = xlYes
End With

On Error Resume Next ' キャンセル用
Application.Dialogs(xlDialogSort).Show

End Sub

Sub test()

Set w = Sheets("Sheet1")

w.Range("A1:B7").Select ' 先に選択しておかないとSetRangeが適用されない

With w.Sort

.SortFields.Clear

.SortFields.Add Key:=w.Range("B1") ' 選択範囲外だと空白になる

.SetRange Selection

.Header = xlYes

End With

On Error Resume Next ' キャンセル用

Application.Dialogs(xlDialogSort).Show

End Sub

2020-08-202020-08-20

VBA ビット演算

各ビットごとの条件式(True/False)として考えるとわかりやすい。

And
左右がTrueでTrue

Or
左右いずれかTrueでTrue

Not
TrueならFalse、FalseならTrue

Xor
左右が違う場合True

VBAでは10進法のまま計算する。

2進法から10進法へは各フラグを下記の数値を足すだけ。
128,64,32,16,8,4,2,1

例えば、
10進法で3なら、00 00 00 11
10進法で6なら、00 00 01 10
なので、Andで計算すると2のフラグのみTrueとなる。

Sub TEST2()

Debug.Print 3 And 6 ' 2

End Sub

Sub TEST2()

Debug.Print 3 And 6 ' 2

End Sub

2,8のフラグを立たせたければ10とすればいい。

Sub TEST2()

f = 10

If f And 1 Then Debug.Print 1
If f And 2 Then Debug.Print 2
If f And 4 Then Debug.Print 4
If f And 8 Then Debug.Print 8
If f And 16 Then Debug.Print 16

' 2, 8

End Sub

Sub TEST2()

f = 10

If f And 1 Then Debug.Print 1

If f And 2 Then Debug.Print 2

If f And 4 Then Debug.Print 4

If f And 8 Then Debug.Print 8

If f And 16 Then Debug.Print 16

' 2, 8

End Sub

2020-08-202020-08-20

VBA 時刻計算で問題

時刻の処理を考えていて、1分ずつ加算するループを試してみたときのこと。

Sub TEST1()

s = TimeValue("2:00 PM")
e = TimeValue("3:15 PM")

t = 0
b = 0

Do While DateDiff("n", s, e) > 0

  If s >= TimeValue("3:00 PM") And s < TimeValue("3:15 PM") Then b = b + 1 '-15

  s = DateAdd("n", 1, s)
  t = t + 1
  
Loop

MsgBox b ' 14

' --------------------------------------------------------

s = TimeValue("2:50 PM")
e = TimeValue("3:15 PM")

t = 0
b = 0

Do While DateDiff("n", s, e) > 0

  If s >= TimeValue("3:00 PM") And s < TimeValue("3:15 PM") Then b = b + 1 '-15

  s = DateAdd("n", 1, s)
  t = t + 1
  
Loop

MsgBox b ' 15

End Sub

Sub TEST1()

s = TimeValue("2:00 PM")

e = TimeValue("3:15 PM")

t = 0

b = 0

Do While DateDiff("n", s, e) > 0

If s >= TimeValue("3:00 PM") And s < TimeValue("3:15 PM") Then b = b + 1 '-15

s = DateAdd("n", 1, s)

t = t + 1

Loop

MsgBox b ' 14

' --------------------------------------------------------

s = TimeValue("2:50 PM")

e = TimeValue("3:15 PM")

t = 0

b = 0

Do While DateDiff("n", s, e) > 0

If s >= TimeValue("3:00 PM") And s < TimeValue("3:15 PM") Then b = b + 1 '-15

s = DateAdd("n", 1, s)

t = t + 1

Loop

MsgBox b ' 15

End Sub

上と下ではスタート(s)の開始時刻が違うだけなのだが、3:00から3:15までというIFに対して上と下で判定が違って、bの値が同じにならない。

比較をDateDiffにすることで解決した。

Sub TEST1()

s = TimeValue("2:00 PM")
e = TimeValue("3:15 PM")

t = 0
b = 0

Do While DateDiff("n", s, e) > 0

  If 0 >= DateDiff("n", s, TimeValue("3:00 PM")) And 0 < DateDiff("n", s, TimeValue("3:15 PM")) Then ' 3:00 - 3:14
    b = b + 1 '-15
  End If
  
  s = DateAdd("n", 1, s)
  t = t + 1
  Debug.Print s & "  _  " & t & "  _  " & b
Loop

MsgBox b ' 15

' --------------------------------------------------------

s = TimeValue("2:50 PM")
e = TimeValue("3:15 PM")

t = 0
b = 0

Do While DateDiff("n", s, e) > 0

  If 0 >= DateDiff("n", s, TimeValue("3:00 PM")) And 0 < DateDiff("n", s, TimeValue("3:15 PM")) Then ' 3:00 - 3:14
    b = b + 1 '-15
  End If

  s = DateAdd("n", 1, s)
  t = t + 1
  
Loop

MsgBox b ' 15

End Sub

Sub TEST1()

s = TimeValue("2:00 PM")

e = TimeValue("3:15 PM")

t = 0

b = 0

Do While DateDiff("n", s, e) > 0

If 0 >= DateDiff("n", s, TimeValue("3:00 PM")) And 0 < DateDiff("n", s, TimeValue("3:15 PM")) Then ' 3:00 - 3:14

b = b + 1 '-15

End If

s = DateAdd("n", 1, s)

t = t + 1

Debug.Print s & " _ " & t & " _ " & b

Loop

MsgBox b ' 15

' --------------------------------------------------------

s = TimeValue("2:50 PM")

e = TimeValue("3:15 PM")

t = 0

b = 0

Do While DateDiff("n", s, e) > 0

If 0 >= DateDiff("n", s, TimeValue("3:00 PM")) And 0 < DateDiff("n", s, TimeValue("3:15 PM")) Then ' 3:00 - 3:14

b = b + 1 '-15

End If

s = DateAdd("n", 1, s)

t = t + 1

Loop

MsgBox b ' 15

End Sub

2020-06-012020-06-01

VBA 仕入台帳から注文書

台帳に入力された内容を注文書の雛形に書き込み、指定したブックに新しいシートとして複写する。レジストリにパスを保存することでブックを記憶することができる。

Sub OrderSheet()

'HKEY_CURRENT_USER\Software\VB and VBA Program Setting

On Error GoTo exception

If (Not ActiveWorkbook Is ThisWorkbook) Then
  MsgBox msg("仕入台帳で起動してください")
  Exit Sub
End If

If ThisWorkbook.ReadOnly = True Then
  If MsgBox("仕入台帳が読み取り専用ですが続けますか？", vbYesNo) = vbNo Then Exit Sub
End If

tRow = Selection(1).Row
bRow = Selection(Selection.Count).Row

If (bRow - tRow) + 1 > 12 Then
  If MsgBox("選択範囲が12行を超えていますが続けますか？", vbYesNo) = vbNo Then Exit Sub
End If

orderBookPath = GetSetting("注文書", "パス", Application.UserName)

If orderBookPath <> "" Then
  isUseRegPath = MsgBox("記憶した保存先を使用しますか？", vbYesNo)
End If

If isUseRegPath = vbYes Then

  Workbooks.Open Filename:=orderBookPath
  orderBookName = ActiveWorkbook.Name
  
Else ' vbNo, Falseの場合

  orderBookPath = Application.GetOpenFilename("Microsoft Excelブック,*.xlsx;*.xlsm")
  If orderBookPath = False Then Exit Sub
  
  SaveSetting "注文書", "パス", Application.UserName, orderBookPath
  
  Workbooks.Open Filename:=orderBookPath
  orderBookName = ActiveWorkbook.Name
  
End If

If Workbooks(orderBookName).ReadOnly = True Then
  If MsgBox("注文書の保存先が読み取り専用ですが続けますか？", vbYesNo) = vbNo Then Exit Sub
End If

Set thissheet = ThisWorkbook.ActiveSheet

If StrConv(thissheet.Range("E" & tRow & "").Text, vbNarrow) Like "*ﾗｷﾞﾝｸﾞ*" Then
  If MsgBox("ラギング注文書を使用しますか？", vbYesNo) = vbYes Then
    ThisWorkbook.Sheets("ラギング注文書").Copy After:=Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count)
  Else
    ThisWorkbook.Sheets("注文書").Copy After:=Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count)
  End If
Else
  ThisWorkbook.Sheets("注文書").Copy After:=Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count)
End If

Set targetSheet = Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count) '注文書の複写後に代入

targetSheet.Range("G9").Value = Application.UserName
targetSheet.Range("A4").Value = thissheet.Range("C" & tRow & "").Text & "　御中"
targetSheet.Range("G15").Value = Format(thissheet.Range("D" & tRow & "").Text, "yymmdd")

If thissheet.Range("D" & tRow & "").Text = "" Then
  targetSheet.Range("G15").Value = Format(Now, "yymmdd")
End If

targetRow = 18
For r = tRow To bRow

  targetSheet.Range("A" & targetRow & "").Value = thissheet.Range("E" & r & "").Value & " " & thissheet.Range("F" & r & "").Value & " " & thissheet.Range("G" & r & "").Value
  targetSheet.Range("B" & targetRow & "").Value = thissheet.Range("M" & r & "").Value
  targetSheet.Range("C" & targetRow & "").Value = thissheet.Range("K" & r & "").Value
  targetSheet.Range("D" & targetRow & "").Value = thissheet.Range("L" & r & "").Value
  
  If thissheet.Range("H" & r & "").Value <> "" Then
    targetSheet.Range("F" & targetRow & "").Value = thissheet.Range("H" & r & "").Value & "へ納品"
  End If
  
  targetSheet.Range("G" & targetRow & "").Value = thissheet.Range("I" & r & "").Value
  targetSheet.Range("H" & targetRow & "").Value = thissheet.Range("J" & r & "").Value
  
targetRow = targetRow + 1

Next r

If MsgBox("仕入台帳を保存しますか？", vbYesNo) = vbYes Then
  ThisWorkbook.Save
End If

If MsgBox("注文書を保存しますか？", vbYesNo) = vbYes Then
  Workbooks(orderBookName).Save
End If

Exit Sub

exception:

MsgBox Err.Description

End Sub

100

101

102

103

104

105

Sub OrderSheet()

'HKEY_CURRENT_USER\Software\VB and VBA Program Setting

On Error GoTo exception

If (Not ActiveWorkbook Is ThisWorkbook) Then

MsgBox msg("仕入台帳で起動してください")

Exit Sub

End If

If ThisWorkbook.ReadOnly = True Then

If MsgBox("仕入台帳が読み取り専用ですが続けますか？", vbYesNo) = vbNo Then Exit Sub

End If

tRow = Selection(1).Row

bRow = Selection(Selection.Count).Row

If (bRow - tRow) + 1 > 12 Then

If MsgBox("選択範囲が12行を超えていますが続けますか？", vbYesNo) = vbNo Then Exit Sub

End If

orderBookPath = GetSetting("注文書", "パス", Application.UserName)

If orderBookPath <> "" Then

isUseRegPath = MsgBox("記憶した保存先を使用しますか？", vbYesNo)

End If

If isUseRegPath = vbYes Then

Workbooks.Open Filename:=orderBookPath

orderBookName = ActiveWorkbook.Name

Else ' vbNo, Falseの場合

orderBookPath = Application.GetOpenFilename("Microsoft Excelブック,*.xlsx;*.xlsm")

If orderBookPath = False Then Exit Sub

SaveSetting "注文書", "パス", Application.UserName, orderBookPath

Workbooks.Open Filename:=orderBookPath

orderBookName = ActiveWorkbook.Name

End If

If Workbooks(orderBookName).ReadOnly = True Then

If MsgBox("注文書の保存先が読み取り専用ですが続けますか？", vbYesNo) = vbNo Then Exit Sub

End If

Set thissheet = ThisWorkbook.ActiveSheet

If StrConv(thissheet.Range("E" & tRow & "").Text, vbNarrow) Like "*ﾗｷﾞﾝｸﾞ*" Then

If MsgBox("ラギング注文書を使用しますか？", vbYesNo) = vbYes Then

ThisWorkbook.Sheets("ラギング注文書").Copy After:=Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count)

Else

ThisWorkbook.Sheets("注文書").Copy After:=Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count)

End If

Else

ThisWorkbook.Sheets("注文書").Copy After:=Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count)

End If

Set targetSheet = Workbooks(orderBookName).Sheets(Workbooks(orderBookName).Sheets.Count) '注文書の複写後に代入

targetSheet.Range("G9").Value = Application.UserName

targetSheet.Range("A4").Value = thissheet.Range("C" & tRow & "").Text & "　御中"

targetSheet.Range("G15").Value = Format(thissheet.Range("D" & tRow & "").Text, "yymmdd")

If thissheet.Range("D" & tRow & "").Text = "" Then

targetSheet.Range("G15").Value = Format(Now, "yymmdd")

End If

targetRow = 18

For r = tRow To bRow

targetSheet.Range("A" & targetRow & "").Value = thissheet.Range("E" & r & "").Value & " " & thissheet.Range("F" & r & "").Value & " " & thissheet.Range("G" & r & "").Value

targetSheet.Range("B" & targetRow & "").Value = thissheet.Range("M" & r & "").Value

targetSheet.Range("C" & targetRow & "").Value = thissheet.Range("K" & r & "").Value

targetSheet.Range("D" & targetRow & "").Value = thissheet.Range("L" & r & "").Value

If thissheet.Range("H" & r & "").Value <> "" Then

targetSheet.Range("F" & targetRow & "").Value = thissheet.Range("H" & r & "").Value & "へ納品"

End If

targetSheet.Range("G" & targetRow & "").Value = thissheet.Range("I" & r & "").Value

targetSheet.Range("H" & targetRow & "").Value = thissheet.Range("J" & r & "").Value

targetRow = targetRow + 1

Next r

If MsgBox("仕入台帳を保存しますか？", vbYesNo) = vbYes Then

ThisWorkbook.Save

End If

If MsgBox("注文書を保存しますか？", vbYesNo) = vbYes Then

Workbooks(orderBookName).Save

End If

Exit Sub

exception:

MsgBox Err.Description

End Sub

2020-05-01

VBA 仕入シートコピー・マスタチェック

以前利用していたVBA

Sub Cp()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
For Each w In Sheets
    If w.Name = "集計" Then Sheets("集計").Delete
Next w
Sheets.Add Before:=Sheets(1)
ActiveSheet.Name = "集計"
For Each w In Worksheets
    If w.Name <> "集計" And w.Name <> "注文書" And w.Name <> "マスタ" Then
        If Sheets("集計").UsedRange.Rows.Count = 1 Then
            r = 1
        Else
            r = Sheets("集計").UsedRange.Rows.Count + 1
        End If
        w.UsedRange.Copy
        Sheets("集計").Cells(r, 1).PasteSpecial Paste:=xlPasteValues
        Sheets("集計").Cells(r, 1).PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
        w.UsedRange.ClearContents
    End If
Next w
c = 16 '材料/外注 = 19, 運送=16
k = 2
For i = 1 To Sheets("集計").UsedRange.Rows.Count
    Application.StatusBar = "重複削除中 ... " & i
    If Sheets("集計").Cells(k, c).Value = "" Or Sheets("集計").Cells(k, c).Value = 0 Or IsNumeric(Sheets("集計").Cells(k, c).Value) = False Then
        Sheets("集計").Rows(k).Delete
    Else
        k = k + 1
    End If
Next i
For Each w In Sheets
    If w.Name <> "集計" Then w.Delete
Next w
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox "done"
End Sub

Sub Cp()

Application.ScreenUpdating = False

Application.EnableEvents = False

Application.Calculation = xlCalculationManual

For Each w In Sheets

If w.Name = "集計" Then Sheets("集計").Delete

Next w

Sheets.Add Before:=Sheets(1)

ActiveSheet.Name = "集計"

For Each w In Worksheets

If w.Name <> "集計" And w.Name <> "注文書" And w.Name <> "マスタ" Then

If Sheets("集計").UsedRange.Rows.Count = 1 Then

r = 1

Else

r = Sheets("集計").UsedRange.Rows.Count + 1

End If

w.UsedRange.Copy

Sheets("集計").Cells(r, 1).PasteSpecial Paste:=xlPasteValues

Sheets("集計").Cells(r, 1).PasteSpecial Paste:=xlPasteFormats

Application.CutCopyMode = False

w.UsedRange.ClearContents

End If

Next w

c = 16 '材料/外注 = 19, 運送=16

k = 2

For i = 1 To Sheets("集計").UsedRange.Rows.Count

Application.StatusBar = "重複削除中 ... " & i

If Sheets("集計").Cells(k, c).Value = "" Or Sheets("集計").Cells(k, c).Value = 0 Or IsNumeric(Sheets("集計").Cells(k, c).Value) = False Then

Sheets("集計").Rows(k).Delete

Else

k = k + 1

End If

Next i

For Each w In Sheets

If w.Name <> "集計" Then w.Delete

Next w

Application.StatusBar = False

Application.ScreenUpdating = True

Application.EnableEvents = True

Application.Calculation = xlCalculationAutomatic

MsgBox "done"

End Sub

Dim supRange As Range

Sub MainLoop()

' アクティブシートで動作するので注意

Call SetMasterRange

Set w = ActiveSheet

r = 3
Do While w.Cells(r, 2).Value <> ""

  If MasterLoop(w.Cells(r, 2).Value, w.Cells(r, 3).Value) = False Then
    MsgBox r & "行にエラーがあります。"
    Exit Sub
  End If

r = r + 1
Loop

End Sub

Sub SetMasterRange()

' 行末ハードコーディングしているので注意

Set w = Sheets("マスタ")
Set supRange = w.Range("B2:C121")

End Sub

Function MasterLoop(supCode, supName)

For r = 2 To supRange.Rows.Count

  If supRange.Cells(r, 3).Value = supName And supRange.Cells(r, 2).Value = supCode Then
    MasterLoop = True
    Exit Function
  End If
  
Next

MasterLoop = False

End Function

Dim supRange As Range

Sub MainLoop()

' アクティブシートで動作するので注意

Call SetMasterRange

Set w = ActiveSheet

r = 3

Do While w.Cells(r, 2).Value <> ""

If MasterLoop(w.Cells(r, 2).Value, w.Cells(r, 3).Value) = False Then

MsgBox r & "行にエラーがあります。"

Exit Sub

End If

r = r + 1

Loop

End Sub

Sub SetMasterRange()

' 行末ハードコーディングしているので注意

Set w = Sheets("マスタ")

Set supRange = w.Range("B2:C121")

End Sub

Function MasterLoop(supCode, supName)

For r = 2 To supRange.Rows.Count

If supRange.Cells(r, 3).Value = supName And supRange.Cells(r, 2).Value = supCode Then

MasterLoop = True

Exit Function

End If

MasterLoop = False

End Function

2020-03-19

VBA VBAからPOSTする方法

Sub test()

'参照設定する場合(Microsoft XML, v6.0)

Dim xml As XMLHTTP60
Set xml = New XMLHTTP60

'参照設定しない場合

'Set 変数名 = CreateObject("MSXML2.XMLHTTP")

url = "https://appbay.org/"
param = ""

xml.Open "POST", url, False
xml.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xml.send (param)

Do While xml.readyState < 4
  DoEvents
Loop

Debug.Print xml.Status
Debug.Print xml.responseText

Set xml = Nothing

End Sub

Sub test()

'参照設定する場合(Microsoft XML, v6.0)

Dim xml As XMLHTTP60

Set xml = New XMLHTTP60

'参照設定しない場合

'Set 変数名 = CreateObject("MSXML2.XMLHTTP")

url = "https://appbay.org/"

param = ""

xml.Open "POST", url, False

xml.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

xml.send (param)

Do While xml.readyState < 4

DoEvents

Loop

Debug.Print xml.Status

Debug.Print xml.responseText

Set xml = Nothing

End Sub

2020-01-262020-01-27

VBA 表からカレンダー形式に変換

前回はJavascript/C#版で今回はVBA版

○○表という感じの帳票を作る場合、行が単位で列が明細というのが一般的。

明細の中に納期や出荷日など日付に関わる情報が入っていることも多く、そこで問題になるのが、この日付情報同士の関係性がパッと把握できないこと。

日付情報がおまけの場合はいいけど、日付情報が重要な場合は把握しやすいフォーマットに変換してみようということで、表からカレンダーに変換する機能を作成してみた。

ループが２重になるので、行数が多い場合は工夫したほうがいいかもしれない。行数が少なければ問題ないと思う。

Sub CreateCalendar()

y = 2020
m = 1

For Each w In Sheets
  If w.Name = "カレンダ" Then
    w.Delete
    Exit For
  End If
Next

Set w = Sheets.Add
w.Name = "カレンダ"

' value

w.Cells(1, 1).Value = y & "年" & m & "月"

w.Cells(2, 1).Value = "日"
w.Cells(2, 2).Value = "月"
w.Cells(2, 3).Value = "火"
w.Cells(2, 4).Value = "水"
w.Cells(2, 5).Value = "木"
w.Cells(2, 6).Value = "金"
w.Cells(2, 7).Value = "土"

startWeekDay = Weekday(DateSerial(y, m, 1)) ' 日1, 月2, 火3, 水4, 木5, 金6, 土7

tmp = DateAdd("m", 1, DateSerial(y, m, 1))
endDay = Day(DateAdd("d", -1, tmp))

counter = 1

For r = 3 To 13 Step 2

  For c = 1 To 7
  
    If (r = 3 And c < startWeekDay) Or (counter > endDay) Then
    
    Else
    
      w.Cells(r, c).Value = counter
      w.Cells(r + 1, c).Value = GetValue(y, m, counter)
      
      counter = counter + 1
    
    End If
    
  Next

Next

' size

w.Columns("A:G").ColumnWidth = 17

w.Rows(1).RowHeight = 24

For Each r In Split("2,3,5,7,9,11,13", ",")
  w.Rows(r).RowHeight = 17
Next

For Each r In Split("4,6,8,10,12,14", ",")
  w.Rows(r).RowHeight = 69
Next

' position

w.Range("A2:G2").HorizontalAlignment = xlCenter

For Each r In Split("3,5,7,9,11,13", ",")
  w.Rows(r).HorizontalAlignment = xlLeft
Next

' border

For Each r In Split("2,3,5,7,9,11,13,15", ",")
  w.Range(w.Cells(CInt(r), 1), w.Cells(CInt(r), 7)).Borders(xlEdgeTop).LineStyle = xlContinuous
Next

For Each c In Split("1,2,3,4,5,6,7,8", ",")
  w.Range(w.Cells(2, CInt(c)), w.Cells(14, CInt(c))).Borders(xlEdgeLeft).LineStyle = xlContinuous
Next

End Sub

Function GetValue(y, m, d)

sheetName = "Sheet1"
matchColumn = 3
valueColumn = 2
startRow = 2
endRow = 11

For r = startRow To endRow

  If DateSerial(y, m, d) = Sheets(sheetName).Cells(r, matchColumn).Value Then
    GetValue = Sheets(sheetName).Cells(r, valueColumn).Value
    Exit Function
  End If

Next

End Function

100

101

102

103

104

105

Sub CreateCalendar()

y = 2020

m = 1

For Each w In Sheets

If w.Name = "カレンダ" Then

w.Delete

Exit For

End If

Set w = Sheets.Add

w.Name = "カレンダ"

' value

w.Cells(1, 1).Value = y & "年" & m & "月"

w.Cells(2, 1).Value = "日"

w.Cells(2, 2).Value = "月"

w.Cells(2, 3).Value = "火"

w.Cells(2, 4).Value = "水"

w.Cells(2, 5).Value = "木"

w.Cells(2, 6).Value = "金"

w.Cells(2, 7).Value = "土"

startWeekDay = Weekday(DateSerial(y, m, 1)) ' 日1, 月2, 火3, 水4, 木5, 金6, 土7

tmp = DateAdd("m", 1, DateSerial(y, m, 1))

endDay = Day(DateAdd("d", -1, tmp))

counter = 1

For r = 3 To 13 Step 2

For c = 1 To 7

If (r = 3 And c < startWeekDay) Or (counter > endDay) Then

Else

w.Cells(r, c).Value = counter

w.Cells(r + 1, c).Value = GetValue(y, m, counter)

counter = counter + 1

End If

' size

w.Columns("A:G").ColumnWidth = 17

w.Rows(1).RowHeight = 24

For Each r In Split("2,3,5,7,9,11,13", ",")

w.Rows(r).RowHeight = 17

For Each r In Split("4,6,8,10,12,14", ",")

w.Rows(r).RowHeight = 69

' position

w.Range("A2:G2").HorizontalAlignment = xlCenter

For Each r In Split("3,5,7,9,11,13", ",")

w.Rows(r).HorizontalAlignment = xlLeft

' border

For Each r In Split("2,3,5,7,9,11,13,15", ",")

w.Range(w.Cells(CInt(r), 1), w.Cells(CInt(r), 7)).Borders(xlEdgeTop).LineStyle = xlContinuous

For Each c In Split("1,2,3,4,5,6,7,8", ",")

w.Range(w.Cells(2, CInt(c)), w.Cells(14, CInt(c))).Borders(xlEdgeLeft).LineStyle = xlContinuous

End Sub

Function GetValue(y, m, d)

sheetName = "Sheet1"

matchColumn = 3

valueColumn = 2

startRow = 2

endRow = 11

For r = startRow To endRow

If DateSerial(y, m, d) = Sheets(sheetName).Cells(r, matchColumn).Value Then

GetValue = Sheets(sheetName).Cells(r, valueColumn).Value

Exit Function

End If

End Function

2020-01-212020-01-22

VBA 講座ワークシート関数を挿入

以前書いたエクセルVBA講座の続きです。

VBA 講座

今回は少し実用的なものとしてループでワークシート関数を挿入する方法をお伝えしたいと思います。

ワークシート関数だからといって挿入自体に特別な方法は必要ありません。そのまま文字として入力すれば大丈夫です。

Sheets("Sheet1").Cells(1, 1).Value = "=SUM(A2:A3)"

1	Sheets("Sheet1").Cells(1, 1).Value = "=SUM(A2:A3)"

これを実行すると、Sheet1というシートのA1セルにSUM関数が入ります。

ではもう少し便利にするためにForループのカウンター変数を利用してみます。

For r = 1 To 4
Sheets("Sheet1").Cells(r, 1).Value = "=SUM(B" & r & ":C" & r & ")"
Next

For r = 1 To 4

Sheets("Sheet1").Cells(r, 1).Value = "=SUM(B" & r & ":C" & r & ")"

細かく見ていきます。

先ずForループの中の処理は4回実行されます。そのときrというカウンタ変数は1,2,3,4というように変化していきます。

rの変化と指定しているセルの位置を考えてみると、
rが1のときCells(1,2)
rが2のときCells(2,2)
rが3のときCells(3,2)
rが4のときCells(4,2)
となります。Cellsの中身は行,列ですので、A1,A2,A3,A4セルを対象にして挿入していることが分かります。

“=SUM(B” & r & “:C” & r & “)”の部分について、文字としてそのまま利用したい部分はダブルクォーテーションで囲い、変数の中身を利用したい部分はダブルクォーテーションで囲わずそのまま記入します。それらを＆記号(左右に半角スペース必須)でつなぎます。

＊＊＊

この部分は分かりづらいのもう少し細かく解説すると、セルの中に書き込める値は２種類(実際はもっとありますが現時点では)あると考えてください。１つはダブルクォーテーションで囲った文字、もう１つは変数で、ダブルクォーテーションで囲った文字はそのまま書き込まれ、変数は中身が利用されます。

そしてその２種類は＆記号(左右に半角スペース必須)で、順番や数に制限なく自由につなぐことができます。

v1 = "hello"
v2 = "world"

MsgBox v1 & " " & v2

v1 = "hello"

v2 = "world"

MsgBox v1 & " " & v2

v1 = "hello"
v2 = " "
v3 = "world"

MsgBox v1 & v2 & v3

v1 = "hello"

v2 = " "

v3 = "world"

MsgBox v1 & v2 & v3

どちらも実行するとhello worldと表示されます。

＊＊＊

話を戻します。

具体的にrの変化を見ていくと、
rが1のとき、”=SUM(B1:C1)”
rが2のとき、”=SUM(B2:C2)”
rが3のとき、”=SUM(B3:C3)”
rが4のとき、”=SUM(B4:C4)”
となります。

結果として
rが1のとき、A1セルに”=SUM(B1:C1)”
rが2のとき、A2セルに”=SUM(B2:C2)”
rが3のとき、A3セルに”=SUM(B3:C3)”
rが4のとき、A4セルに”=SUM(B4:C4)”
が入るということになります。

Forループのカウンタ変数をループの中で利用することはよくあります。むしろループの中で固定の文字列を挿入することの方が少ないぐらいです。

さらにカウンタ変数を利用したワークシート関数を挿入する方法が使えるようになると、かなり複雑なことができるようになります。

2020-01-142020-05-10

VBA SQL実験用④(SQLite)

最近では専門家ではなくてもデータ分析ができたほうがいいという話をよく聞きます。そういう話の中で利用されているソフトはだいたい専用ソフトかエクセルといった感じでしょうか。

ただ数は少ないですがSQLを使おうというのもあるようです。実際SQLは非常に便利でエクセルより多少敷居は高いですが、少し使えればエクセルでは面倒な処理も簡単にできたりします。経験上、ワークシート関数、VBA、SQLを使い分ければほとんどの処理ができると思います。

ですが、いざSQLを使おうとするとどのソフトを使ったらいいのか迷うと思います。一般的にはAccess、SQL Server、MySQL(MariaDB)、SQLiteあたりがお勧めされていますが、もしPCにAccessが入っているならAccessが一番手軽に始められるのではないかと思います。今回はSQLiteを採用していますが、私も最初はAccessを使っていました。

中小企業で働いているとデータ分析やITの専門家がいない場合も多いので、自分たちで少しでもデータ分析ができると役に立つことが多いです。

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add
.OnAction = "CreateTable"
.Caption = "テーブル作成"
End With

With Application.CommandBars("cell").Controls.Add
.OnAction = "QuerySelect"
.Caption = "SQL実行"
End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2
  Application.CommandBars("cell").Controls("テーブル作成").Delete
  Application.CommandBars("cell").Controls("SQL実行").Delete
Next i

End Sub

Function GetCon()

GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & ThisWorkbook.Path & "\dat"

End Function

Function GetType(s)

'型はSQLite以外の互換性のため

Select Case s
  Case "s"
  tmp = "varchar(255)"
  Case "i"
  tmp = "bigint"
  Case "m"
  tmp = "money"
  Case "d"
  tmp = "datetime"
End Select

GetType = tmp

End Function

Sub CreateTable()

Set cn = CreateObject("adodb.connection")
cn.Open GetCon

tbl = InputBox("テーブル名")
If tbl = "" Then Exit Sub

'テーブル削除

On Error Resume Next
cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

  tmp = GetType(Right(ActiveSheet.Cells(Selection(1).Row, c).Value, 1))
  fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & " " & tmp & ","

Next c

fld = Left(fld, Len(fld) - 1)

q = "create table " & tbl & " (id integer primary key," & fld & ")"
cn.Execute q: Debug.Print q

'データ登録

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column
  fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & ","
Next c

fld = Left(fld, Len(fld) - 1)

For r = (Selection(1).Row) + 1 To Selection(Selection.Count).Row
  For cc = Selection(1).Column To Selection(Selection.Count).Column
    rec = rec & "'" & ActiveSheet.Cells(r, cc).Value & "'" & ","
  Next cc

  rec = Left(rec, Len(rec) - 1)
  
  q = "insert into " & tbl & " (" & fld & ") values (" & rec & ")"
  cn.Execute q: Debug.Print q

  rec = ""
Next r

If cn.State = 1 Then cn.Close
Set cn = Nothing

MsgBox "done"

End Sub

Sub ExecuteQuery(q)

Set cn = CreateObject("adodb.connection")
Set rn = CreateObject("adodb.recordset")

cn.Open GetCon
rn.Open q, cn

'フィールド作成

i = 0

For c = Selection(1).Column To (Selection(1).Column + rn.Fields.Count) - 1
  Cells(Selection(Selection.Count).Row + 1, c).Value = rn.Fields(i).Name
  i = i + 1
Next c

'データ読込

Cells(Selection(Selection.Count).Row + 2, Selection(1).Column).CopyFromRecordset rn

If rn.State = 1 Then rn.Close
Set rn = Nothing

If cn.State = 1 Then cn.Close
Set cn = Nothing

End Sub

Sub ExecuteNonQuery(q)

Set cn = CreateObject("adodb.connection")

cn.Open GetCon
cn.Execute q

If cn.State = 1 Then cn.Close
Set cn = Nothing

End Sub

Sub QuerySelect()

If Selection.Rows.Count = 1 Then
  q = ActiveCell.Value
Else
  For r = 1 To Selection.Rows.Count
    q = q & " " & Selection(r)
  Next r
End If

If Left(q, 1) = "s" Then
  ExecuteQuery (q)
Else
  ExecuteNonQuery (q)
End If

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add

.OnAction = "CreateTable"

.Caption = "テーブル作成"

End With

With Application.CommandBars("cell").Controls.Add

.OnAction = "QuerySelect"

.Caption = "SQL実行"

End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2

Application.CommandBars("cell").Controls("テーブル作成").Delete

Application.CommandBars("cell").Controls("SQL実行").Delete

Next i

End Sub

Function GetCon()

GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & ThisWorkbook.Path & "\dat"

End Function

Function GetType(s)

'型はSQLite以外の互換性のため

Select Case s

Case "s"

tmp = "varchar(255)"

Case "i"

tmp = "bigint"

Case "m"

tmp = "money"

Case "d"

tmp = "datetime"

End Select

GetType = tmp

End Function

Sub CreateTable()

Set cn = CreateObject("adodb.connection")

cn.Open GetCon

tbl = InputBox("テーブル名")

If tbl = "" Then Exit Sub

'テーブル削除

On Error Resume Next

cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

tmp = GetType(Right(ActiveSheet.Cells(Selection(1).Row, c).Value, 1))

fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & " " & tmp & ","

Next c

fld = Left(fld, Len(fld) - 1)

q = "create table " & tbl & " (id integer primary key," & fld & ")"

cn.Execute q: Debug.Print q

'データ登録

fld = ""

For c = Selection(1).Column To Selection(Selection.Count).Column

fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & ","

Next c

fld = Left(fld, Len(fld) - 1)

For r = (Selection(1).Row) + 1 To Selection(Selection.Count).Row

For cc = Selection(1).Column To Selection(Selection.Count).Column

rec = rec & "'" & ActiveSheet.Cells(r, cc).Value & "'" & ","

Next cc

rec = Left(rec, Len(rec) - 1)

q = "insert into " & tbl & " (" & fld & ") values (" & rec & ")"

cn.Execute q: Debug.Print q

rec = ""

Next r

If cn.State = 1 Then cn.Close

Set cn = Nothing

MsgBox "done"

End Sub

Sub ExecuteQuery(q)

Set cn = CreateObject("adodb.connection")

Set rn = CreateObject("adodb.recordset")

cn.Open GetCon

rn.Open q, cn

'フィールド作成

i = 0

For c = Selection(1).Column To (Selection(1).Column + rn.Fields.Count) - 1

Cells(Selection(Selection.Count).Row + 1, c).Value = rn.Fields(i).Name

i = i + 1

Next c

'データ読込

Cells(Selection(Selection.Count).Row + 2, Selection(1).Column).CopyFromRecordset rn

If rn.State = 1 Then rn.Close

Set rn = Nothing

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub

Sub ExecuteNonQuery(q)

Set cn = CreateObject("adodb.connection")

cn.Open GetCon

cn.Execute q

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub

Sub QuerySelect()

If Selection.Rows.Count = 1 Then

q = ActiveCell.Value

Else

For r = 1 To Selection.Rows.Count

q = q & " " & Selection(r)

Next r

End If

If Left(q, 1) = "s" Then

ExecuteQuery (q)

Else

ExecuteNonQuery (q)

End If

End Sub

追記

ちょっと原因は分からないけど、SQLite標準のカラムのデータ型(textやinteger)でテーブルを作成するとCopyFromRecordsetで取得できなくなる。

varchar(255)をカラムのデータ型に指定しているとCopyFromRecordsetで問題なく取得できる。

CopyFromRecordsetはテーブル作成時の型の影響を受けているらしい。とりあえずCopyFromRecordsetを使わないパターン

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add
.OnAction = "CreateTable"
.Caption = "テーブル作成"
End With

With Application.CommandBars("cell").Controls.Add
.OnAction = "QuerySelect"
.Caption = "SQL実行"
End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2
  Application.CommandBars("cell").Controls("テーブル作成").Delete
  Application.CommandBars("cell").Controls("SQL実行").Delete
Next i

End Sub

Function GetCon()

'GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & ThisWorkbook.Path & "\dat"
GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & Sheets("設定").Cells(1, 2).Value

End Function

Function GetType(s)

Select Case s
  Case "s"
  tmp = "text"
  Case "i"
  tmp = "integer"
End Select

GetType = tmp

End Function

Sub CreateTable()

Set cn = CreateObject("adodb.connection")
cn.Open GetCon

tbl = InputBox("テーブル名")
If tbl = "" Then Exit Sub

'テーブル削除

On Error Resume Next
cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

Set topLeft = Selection(1)
Set bottomRight = Selection(Selection.Count)

head = ""
For c = topLeft.Column To bottomRight.Column
  tmp = GetType(Right(ActiveSheet.Cells(topLeft.Row, c).Value, 1))
  head = head & ActiveSheet.Cells(topLeft.Row, c).Value & " " & tmp & ","
Next c

head = Left(head, Len(head) - 1)

q = "create table " & tbl & " (id integer primary key," & head & ")"
cn.Execute q

'データ登録

head = ""
For c = topLeft.Column To bottomRight.Column
  head = head & ActiveSheet.Cells(topLeft.Row, c).Value & ","
Next c

head = Left(head, Len(head) - 1)
For r = topLeft.Row + 1 To bottomRight.Row

  For c = topLeft.Column To bottomRight.Column
    body = body & "'" & ActiveSheet.Cells(r, c).Value & "'" & ","
  Next c

  body = Left(body, Len(body) - 1)
  
  q = "insert into " & tbl & " (" & head & ") values (" & body & ")"
  cn.Execute q

  body = ""
  
Next r

If cn.State = 1 Then cn.Close
Set cn = Nothing

MsgBox "done"

End Sub

Sub ExecuteQuery(q)

Set cn = CreateObject("adodb.connection")
Set rn = CreateObject("adodb.recordset")

cn.Open GetCon
rn.Open q, cn

Set topLeft = Selection(1)
Set bottomRight = Selection(Selection.Count)

'見出

i = 0
For c = topLeft.Column To (topLeft.Column + rn.Fields.Count) - 1
  ActiveSheet.Cells(bottomRight.Row + 1, c).Value = rn.Fields(i).Name
  i = i + 1
Next c

'本体

r = 2
Do Until rn.EOF

  i = 0
  For c = topLeft.Column To (topLeft.Column + rn.Fields.Count) - 1
    ActiveSheet.Cells(bottomRight.Row + r, c).Value = rn.Fields(i)
    i = i + 1
  Next c
  
  rn.MoveNext
  r = r + 1
Loop

If rn.State = 1 Then rn.Close
Set rn = Nothing

If cn.State = 1 Then cn.Close
Set cn = Nothing

End Sub

Sub ExecuteNonQuery(q)

Set cn = CreateObject("adodb.connection")

cn.Open GetCon
cn.Execute q

If cn.State = 1 Then cn.Close
Set cn = Nothing

End Sub

Sub QuerySelect()

If Selection.Rows.Count = 1 Then
  q = ActiveCell.Value
Else
  For r = 1 To Selection.Rows.Count
    q = q & " " & Selection(r)
  Next r
End If

If Left(q, 1) = "s" Then
  ExecuteQuery (q)
Else
  ExecuteNonQuery (q)
End If

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

Sub auto_open()

Application.CommandBars("cell").Reset

With Application.CommandBars("cell").Controls.Add

.OnAction = "CreateTable"

.Caption = "テーブル作成"

End With

With Application.CommandBars("cell").Controls.Add

.OnAction = "QuerySelect"

.Caption = "SQL実行"

End With

End Sub

Sub auto_close()

On Error Resume Next

For i = 1 To 2

Application.CommandBars("cell").Controls("テーブル作成").Delete

Application.CommandBars("cell").Controls("SQL実行").Delete

Next i

End Sub

Function GetCon()

'GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & ThisWorkbook.Path & "\dat"

GetCon = "DRIVER=SQLite3 ODBC Driver; DataBase=" & Sheets("設定").Cells(1, 2).Value

End Function

Function GetType(s)

Select Case s

Case "s"

tmp = "text"

Case "i"

tmp = "integer"

End Select

GetType = tmp

End Function

Sub CreateTable()

Set cn = CreateObject("adodb.connection")

cn.Open GetCon

tbl = InputBox("テーブル名")

If tbl = "" Then Exit Sub

'テーブル削除

On Error Resume Next

cn.Execute "drop table " & tbl

'テーブル作成

On Error GoTo 0

Set topLeft = Selection(1)

Set bottomRight = Selection(Selection.Count)

head = ""

For c = topLeft.Column To bottomRight.Column

tmp = GetType(Right(ActiveSheet.Cells(topLeft.Row, c).Value, 1))

head = head & ActiveSheet.Cells(topLeft.Row, c).Value & " " & tmp & ","

Next c

head = Left(head, Len(head) - 1)

q = "create table " & tbl & " (id integer primary key," & head & ")"

cn.Execute q

'データ登録

head = ""

For c = topLeft.Column To bottomRight.Column

head = head & ActiveSheet.Cells(topLeft.Row, c).Value & ","

Next c

head = Left(head, Len(head) - 1)

For r = topLeft.Row + 1 To bottomRight.Row

For c = topLeft.Column To bottomRight.Column

body = body & "'" & ActiveSheet.Cells(r, c).Value & "'" & ","

Next c

body = Left(body, Len(body) - 1)

q = "insert into " & tbl & " (" & head & ") values (" & body & ")"

cn.Execute q

body = ""

Next r

If cn.State = 1 Then cn.Close

Set cn = Nothing

MsgBox "done"

End Sub

Sub ExecuteQuery(q)

Set cn = CreateObject("adodb.connection")

Set rn = CreateObject("adodb.recordset")

cn.Open GetCon

rn.Open q, cn

Set topLeft = Selection(1)

Set bottomRight = Selection(Selection.Count)

'見出

i = 0

For c = topLeft.Column To (topLeft.Column + rn.Fields.Count) - 1

ActiveSheet.Cells(bottomRight.Row + 1, c).Value = rn.Fields(i).Name

i = i + 1

Next c

'本体

r = 2

Do Until rn.EOF

i = 0

For c = topLeft.Column To (topLeft.Column + rn.Fields.Count) - 1

ActiveSheet.Cells(bottomRight.Row + r, c).Value = rn.Fields(i)

i = i + 1

Next c

rn.MoveNext

r = r + 1

Loop

If rn.State = 1 Then rn.Close

Set rn = Nothing

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub

Sub ExecuteNonQuery(q)

Set cn = CreateObject("adodb.connection")

cn.Open GetCon

cn.Execute q

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub

Sub QuerySelect()

If Selection.Rows.Count = 1 Then

q = ActiveCell.Value

Else

For r = 1 To Selection.Rows.Count

q = q & " " & Selection(r)

Next r

End If

If Left(q, 1) = "s" Then

ExecuteQuery (q)

Else

ExecuteNonQuery (q)

End If

End Sub