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

2020-09-092022-03-16

VBA 並び替え(Sort)

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

Sub test()

Set w = Sheets("Sheet1")

With w.Sort

' 条件設定

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

.SortFields.Clear
.SortFields.Add _
  Key:=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:=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

2020-01-042020-01-13

VBA 講座

エクセルにはVBAという開発環境が付属しており、VBAを活用するとエクセル上の作業を自動化したりすることができます。

大手企業では業務ごとに専用ソフトを導入していたり、開発の専門部署があったりしますので、一般の従業員がVBAを使う機会は少ないかもしれませんが、中小企業ではVBAを使うと業務を効率化することができます。

私もそれほど詳しくありませんが、実際に今までいくつかVBAを業務に役立ててきましたので、ここではその経験を分かりやすくお伝えしていきたいと思います。

VBAを始めるにあたって何が大変なのかというと、面白くもない基礎知識を覚えなければいけないということがあります。VBAはプログラミング言語の一種なので、プログラミング未経験の人からすると、最初に覚えなければいけない内容もかなりの量になってしまいます。

やりたいことは明確なのに、すぐにそこに行けないのはもどかしいものです。ですので、ここではなるべく早く使えるようになることを目標にして、細かい部分は省き、必要なことは作りながら覚えればいいという考えで進めたいと思います。

また、VBAなどプログラミングではやりたいことに対して複数の方法が存在するのですが、これもあえて一つの方法を採用してしまおうかと思います。

VBAの実行方法

開発タブ＞挿入＞ActiveXコントロール＞コマンドボタン
追加されたコマンドボタンをダブルクリックします。

VBA用のエディタが表示されたと思います。

表示された
Private Sub CommandButton1_Click()
と
End Sub
の間に処理を記入していくことになります。

もし開発タブが表示されていない場合は、
ファイル＞オプション＞リボンのユーザー設定
開発にチェックを付けます。

ではどうやってVBAを実行するのか？ですが、開発タブの中にデザインモードというボタンがあり、これが押されている状態では今のようにVBAのエディタが開きます。

デザインモードのボタンをもう一度押すと、デザインモードが押されていない状態になり、その状態でコマンドボタンを押すとVBAが実行されます。

開発中にわざわざボタンを押さずに、素早く実行したい場合は、
Private Sub CommandButton1_Click()
と
End Sub
の間にカーソルがある状態で、VBA用エディタの再生ボタンを押すことで実行できます。

セルに値を入れる

Sheets(“Sheet1”).Cells(1, 1).Value = “1”

セルに値を入れるときはこのように書きます。どのシートなのか、どのセルなのかを指定し、そのセルの中身をValueで指定します。

ちなみ、セルを指定しているのだからわざわざValueは必要ないのでは？と思うかもしれません。(実際なくても動くのですが)なぜValueが必要なのかというと、セルの塗りつぶしなどセルの中身とは関係ない部分を指定することもあるので、中身はValueで操作できるよと覚えておいてください。

細かくみていくと、
Sheets(“シート名”)
でシート名を指定し、
Cells(行, 列)
で何行目の何列目にあるセルなのかを指定し、
Value
で指定したセルの値を操作できるという意味です。

ここでのイコールは代入(入れる)という意味です。つまりSheet1の1行目で1列目のセルに”1″を入れるという意味です。

数値と文字

VBAでは数値だったらそのまま直接(1など)書くことができます。文字だったらダブルクォーテーションで囲う(“1″など)必要があります。でも今回1をダブルクォーテーションで囲ってなかった？と思うかもしれません。

少し難しい話ですが、1と”1″は一般的なプログラミングでは数値の1と文字の1として区別されます。いくつか違いはありますが、数値の1は四則演算できて、文字の1は四則演算できないというような違いがあります。つまり上記では数値ではなく文字の1を代入したということです。

VBAの特徴として、文字の数値(“1″など)でも、どうやら数値として使ってるっぽいなとVBAが判断すると自動で数値として扱ってくれます。

このあたりを正確に理解しようとすると型というものが出てきてしまうので、今は数値と文字の違いはあるけど、VBAはいい具合に判断してくれる程度に理解しておけば大丈夫です。

値のコピー

セルの書式や文字色などもコピーできるのですが、最初は値だけコピーする方法を覚えておけば大丈夫です。Valueを使ってイコールで代入するだけです。

Sheets("Sheet1").Cells(1, 1).Value = Sheets("Sheet1").Cells(2, 2).Value

1	Sheets("Sheet1").Cells(1, 1).Value = Sheets("Sheet1").Cells(2, 2).Value

値の表示(MsgBox)

次はセルの値を表示してみます。

MsgBox Sheets(“Sheet1”).Cells(1, 1).Value

代入ではないのでイコールはありません。代わりにMsgBoxと書かれています。これで指定した値をダイアログで表示することができます。Sheet1の1行目1列目のセルの値が表示されます。

ちなみに
MsgBox “A”
などのように表示する値を直接指定することも可能です。

MsgBoxはデバッグとしても利用されます。例えばプログラムを作っている最中に変数の中身を確認したい場合など頻繁にMsgBoxは利用されます。

v = "1"
MsgBox v
v = "2"
MsgBox v

v = "1"

MsgBox v

v = "2"

MsgBox v

ループ(For文)

セルの値を１つずつ設定したり取得したりするだけでは手作業と大きな違いはありません。VBAのメリットは多くの処理を自動化できることですが、ループは自動化の基本の一つです。

For i = 1 To 10
Sheets("Sheet1").Cells(i, 1).Value = i
Next

For i = 1 To 10

Sheets("Sheet1").Cells(i, 1).Value = i

これを実行するとA列の1～10行目に1～10の値が入ります。

For 変数 = 開始値 to 終了値
　処理
Next

というのが基本です。

現時点では変数というのは入れ物と理解しておけば大丈夫です。名前も自由につけることができ、ここではiとしていますが、counterなどとしても大丈夫です。

変数iには1から10まで順番に代入され、そのたびに処理が実行されるということです。具体的にいうと
変数iが1のとき、
Sheets(“Sheet1”).Cells(1, 1).Value = 1
として処理されます。
変数iが2のとき、
Sheets(“Sheet1”).Cells(2, 1).Value = 2
として処理されます。
このように、iが10になるまで繰り返されていきます。

また、変数は1からの必要はありませんし、処理の中で使わなくても問題ありません。

For i = 2 To 3
MsgBox "A"
Next

For i = 2 To 3

MsgBox "A"

これだとAが2回表示されるだけです。処理でiは使っていません。ループを2回するだけです。

条件

次に説明するDo-WhileとIfで条件というのがでてきます。条件とは2つの変数あるいは直接の値を指定し、その2つの間に下記の式を書いてそれが満たされた場合、True(処理の実行)となり、満たされない場合、False(処理が実行されない)となります。

条件は
A = B (AとBが同じ)
A <> B (AとBが違う)
A >= B (AがB以上)
A <= B (AがB以下)
A > B (AがBより大きい)
A < B (AがBより小さい)
のような種類があります。

実際AとBには変数か値が入ります。
変数　条件　変数
変数　条件　　値
　値　条件　変数
　値　条件　　値
いずれの組み合わせてでも大丈夫です。

条件はOrとAndを使うことで複数同時に使うこともできます。意味はそのまま、Orであればどちらかの条件を満たす、Andであれば両方の条件を満たすという意味になります。

例えば
c = 5 Or r = 5
であれば、cという変数の中に5が入っている状態か、rという変数の中に5が入っている状態のどちらか一方でTrueとなります。

c = 5 And r = 5
であれば、cという変数の中に5が入っている状態であり、rという変数の中にも5が入っている状態ではじめてTrueとなります。

ループ(Do-While文)

Do While 条件
　処理
Loop
が基本です。

条件が満たされている間処理をします。

i = 1
Do While i <= 3
  MsgBox i
  i = i + 1
Loop

i = 1

Do While i <= 3

MsgBox i

i = i + 1

Loop

これで1から3まで表示されます。

同じループでForと何が違うの？と思うかもしれません。実際、同じことをしようと思えばどちらを使ってもできます。

使い分けとして、データ量が固定の範囲をループさせる場合はForを使い、データがどんどん追加されていくようなタイプの範囲をループさせる場合はDo-Whileを使うという感じです。

条件分岐(If文)

ある条件が満たされる場合のみ処理を実行することができます。

If 条件 Then
　処理
End If
が基本となります。

Sub test()

If 5 >= 5 Then
  MsgBox "Hello" '表示される
End If

If 5 > 5 Then
  MsgBox "World" ' 表示されない
End If

If "5" >= 5 Then
  MsgBox "!!!" ' 表示される
End If

End Sub

Sub test()

If 5 >= 5 Then

MsgBox "Hello" '表示される

End If

If 5 > 5 Then

MsgBox "World" ' 表示されない

End If

If "5" >= 5 Then

MsgBox "!!!" ' 表示される

End If

End Sub

このように書くことができます。

既に少し説明しましたが、VBAでは文字と数値をうまい具合に扱ってくれます。一般的なプログラミングでは数値と文字は比較できないので、例えば”5″と5は比較できません。この辺りの特徴は少し意識しておいたほうがいいかもしれません。

If文ではだいたい同時ElseIfやElseも説明されていることが多いですが、とりあえず今の段階では使わなくても大丈夫です。

実用例

ここまでの説明で少し実用的なものを作ってみます。Sheet1のデータに条件を1つ通してSheet2にコピーしてみます。

Sheet1には2列データが入っていて、1列目には名称、2列目には数量を入れてあります。1列目が空白になるまでループし、2列目が0の場合はコピーしないという処理をおこないます。

targetRow = 1 '書き込み対象行

r = 2
Do While Sheets("Sheet1").Cells(r, 1).Value <> ""

  n = Sheets("Sheet1").Cells(r, 1).Value
  q = Sheets("Sheet1").Cells(r, 2).Value
  
  If q <> "0" Then
    
    Sheets("Sheet2").Cells(targetRow, 1).Value = n
    Sheets("Sheet2").Cells(targetRow, 2).Value = q
    rr = rr + 1
    
  End If
  
  r = r + 1
Loop

targetRow = 1 '書き込み対象行

r = 2

Do While Sheets("Sheet1").Cells(r, 1).Value <> ""

n = Sheets("Sheet1").Cells(r, 1).Value

q = Sheets("Sheet1").Cells(r, 2).Value

If q <> "0" Then

Sheets("Sheet2").Cells(targetRow, 1).Value = n

Sheets("Sheet2").Cells(targetRow, 2).Value = q

rr = rr + 1

End If

r = r + 1

Loop

非常に簡単な例ですが、手作業では困難な程度の量になってくると自動化が役に立つと思います。