VBA – テックメモ

2020-11-10

VBA ListBox参考

ListBoxの使い方を忘れてしまうので、さっき作ったものをメモ代わり。

Private Sub CommandButton1_Click()

' 検索

TextBox1.Enabled = False
CommandButton1.Enabled = False

Set w = Sheets("dat")

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

  If TextBox1.Text = w.Cells(r, 1).Value Then

    TextBox2.Text = w.Cells(r, 3).Value
    TextBox3.Text = w.Cells(r, 10).Value
    TextBox4.Text = w.Cells(r, 11).Value
    TextBox5.Text = w.Cells(r, 17).Value
    Label7.caption = r
    CommandButton2.Enabled = True
    
    Call CheckDate
    Exit Sub
  
  End If

r = r + 1
Loop

TextBox1.Enabled = True
CommandButton1.Enabled = True

End Sub

Sub CheckDate()

On Error GoTo exception

s = CDate(TextBox3.Text)
e = CDate(TextBox4.Text)
e = DateAdd("d", 1, e)

' 今日が開始日より後で終了日より前

If s < Now And e > Now Then
  Label8.caption = "OK"
Else
  Label8.caption = "NG"
End If
    
Exit Sub

exception:

Label8.caption = "-"

End Sub

Private Sub CommandButton2_Click()

' 今日の日付を登録

Set w = Sheets("dat")

If TextBox5.Text <> "" Then
  result = TextBox5.Text & ", " & Month(Now) & "/" & Day(Now)
Else
  result = Month(Now) & "/" & Day(Now)
End If

If TextBox6.Text <> "" Then
  result = result & "(" & TextBox6.Text & ")"
End If

r = Label7.caption
w.Cells(r, 17).Value = result
TextBox5.Text = result

' CommandButton2.Enabled = False

w.Activate
w.Rows(r).Select

MsgBox "登録しました。"

End Sub

Private Sub CommandButton3_Click()

' キャンセル

TextBox1.Enabled = True
CommandButton1.Enabled = True

TextBox1.Text = ""
TextBox2.Text = ""
TextBox3.Text = ""
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = ""
Label7.caption = ""
Label8.caption = ""

CommandButton2.Enabled = False
TextBox1.SetFocus
    
End Sub

Private Sub CommandButton5_Click()

' シート書き込み

If ListBox2.ListCount = 0 Then Exit Sub

yesNo = vbYes
If TextBox2.Text = "" Then yesNo = MsgBox("氏名がありません。登録しますか？", vbYesNo)
If yesNo = vbNo Then Exit Sub

Set w = Sheets("売上")

r = 1
Do While w.Cells(r, 4).Value <> "" ' 商品名で最終行を算出
  r = r + 1
Loop
targetRow = r

memberCode = TextBox1.Text
memberName = TextBox2.Text

For r = 0 To ListBox2.ListCount - 1

  productName = ListBox2.List(r, 0)
  unitPrice = ListBox2.List(r, 1)
  amount = ListBox2.List(r, 2)
  
  w.Cells(targetRow, 1).Value = DateTime.Now
  w.Cells(targetRow, 2).Value = memberCode
  w.Cells(targetRow, 3).Value = memberName
  w.Cells(targetRow, 4).Value = productName
  w.Cells(targetRow, 5).Value = unitPrice
  w.Cells(targetRow, 6).Value = amount
  
  targetRow = targetRow + 1
  
Next r

w.Activate
w.Rows(targetRow - 1).Select

MsgBox "登録しました。"

End Sub

Private Sub CommandButton6_Click()

' クリア

ComboBox1.Text = ""
ListBox2.Clear
Label12.caption = ""

End Sub

Private Sub UserForm_Initialize()

TextBox1.SetFocus
MasterSetup

End Sub

Sub MasterSetup()

' 商品リスト

ListBox1.ColumnCount = 2

Set w = Sheets("master")

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

  productName = w.Cells(r, 1).Value
  unitPrice = w.Cells(r, 2).Value
  ListBox1.AddItem ""
  ListBox1.List(ListBox1.ListCount - 1, 0) = productName
  ListBox1.List(ListBox1.ListCount - 1, 1) = unitPrice

r = r + 1
Loop

' 売上リスト

ListBox2.ColumnCount = 4


' 数量
For i = 1 To 10
  ComboBox1.AddItem i
Next

End Sub

Private Sub CommandButton4_Click()

' 転送

If ListBox1.Text = "" Then
  MsgBox "商品を選択してください。"
  Exit Sub
End If

If ComboBox1.Text = "" Then
  MsgBox "数量を選択してください。"
  Exit Sub
End If

productName = ListBox1.List(ListBox1.ListIndex, 0)
unitPrice = ListBox1.List(ListBox1.ListIndex, 1)
amount = ComboBox1.Text

ListBox2.AddItem ""
ListBox2.List(ListBox2.ListCount - 1, 0) = productName
ListBox2.List(ListBox2.ListCount - 1, 1) = unitPrice
ListBox2.List(ListBox2.ListCount - 1, 2) = amount
ListBox2.List(ListBox2.ListCount - 1, 3) = CDec(unitPrice) * CDec(amount)

TotalPrice

End Sub

Sub TotalPrice()

result = 0
For r = 0 To ListBox2.ListCount - 1
  result = CDec(result) + CDec(ListBox2.List(r, 3))
Next r

Label12.caption = "\ " & result

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

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

Private Sub CommandButton1_Click()

' 検索

TextBox1.Enabled = False

CommandButton1.Enabled = False

Set w = Sheets("dat")

r = 2

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

If TextBox1.Text = w.Cells(r, 1).Value Then

TextBox2.Text = w.Cells(r, 3).Value

TextBox3.Text = w.Cells(r, 10).Value

TextBox4.Text = w.Cells(r, 11).Value

TextBox5.Text = w.Cells(r, 17).Value

Label7.caption = r

CommandButton2.Enabled = True

Call CheckDate

Exit Sub

End If

r = r + 1

Loop

TextBox1.Enabled = True

CommandButton1.Enabled = True

End Sub

Sub CheckDate()

On Error GoTo exception

s = CDate(TextBox3.Text)

e = CDate(TextBox4.Text)

e = DateAdd("d", 1, e)

' 今日が開始日より後で終了日より前

If s < Now And e > Now Then

Label8.caption = "OK"

Else

Label8.caption = "NG"

End If

Exit Sub

exception:

Label8.caption = "-"

End Sub

Private Sub CommandButton2_Click()

' 今日の日付を登録

Set w = Sheets("dat")

If TextBox5.Text <> "" Then

result = TextBox5.Text & ", " & Month(Now) & "/" & Day(Now)

Else

result = Month(Now) & "/" & Day(Now)

End If

If TextBox6.Text <> "" Then

result = result & "(" & TextBox6.Text & ")"

End If

r = Label7.caption

w.Cells(r, 17).Value = result

TextBox5.Text = result

' CommandButton2.Enabled = False

w.Activate

w.Rows(r).Select

MsgBox "登録しました。"

End Sub

Private Sub CommandButton3_Click()

' キャンセル

TextBox1.Enabled = True

CommandButton1.Enabled = True

TextBox1.Text = ""

TextBox2.Text = ""

TextBox3.Text = ""

TextBox4.Text = ""

TextBox5.Text = ""

TextBox6.Text = ""

Label7.caption = ""

Label8.caption = ""

CommandButton2.Enabled = False

TextBox1.SetFocus

End Sub

Private Sub CommandButton5_Click()

' シート書き込み

If ListBox2.ListCount = 0 Then Exit Sub

yesNo = vbYes

If TextBox2.Text = "" Then yesNo = MsgBox("氏名がありません。登録しますか？", vbYesNo)

If yesNo = vbNo Then Exit Sub

Set w = Sheets("売上")

r = 1

Do While w.Cells(r, 4).Value <> "" ' 商品名で最終行を算出

r = r + 1

Loop

targetRow = r

memberCode = TextBox1.Text

memberName = TextBox2.Text

For r = 0 To ListBox2.ListCount - 1

productName = ListBox2.List(r, 0)

unitPrice = ListBox2.List(r, 1)

amount = ListBox2.List(r, 2)

w.Cells(targetRow, 1).Value = DateTime.Now

w.Cells(targetRow, 2).Value = memberCode

w.Cells(targetRow, 3).Value = memberName

w.Cells(targetRow, 4).Value = productName

w.Cells(targetRow, 5).Value = unitPrice

w.Cells(targetRow, 6).Value = amount

targetRow = targetRow + 1

Next r

w.Activate

w.Rows(targetRow - 1).Select

MsgBox "登録しました。"

End Sub

Private Sub CommandButton6_Click()

' クリア

ComboBox1.Text = ""

ListBox2.Clear

Label12.caption = ""

End Sub

Private Sub UserForm_Initialize()

TextBox1.SetFocus

MasterSetup

End Sub

Sub MasterSetup()

' 商品リスト

ListBox1.ColumnCount = 2

Set w = Sheets("master")

r = 2

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

productName = w.Cells(r, 1).Value

unitPrice = w.Cells(r, 2).Value

ListBox1.AddItem ""

ListBox1.List(ListBox1.ListCount - 1, 0) = productName

ListBox1.List(ListBox1.ListCount - 1, 1) = unitPrice

r = r + 1

Loop

' 売上リスト

ListBox2.ColumnCount = 4

' 数量

For i = 1 To 10

ComboBox1.AddItem i

End Sub

Private Sub CommandButton4_Click()

' 転送

If ListBox1.Text = "" Then

MsgBox "商品を選択してください。"

Exit Sub

End If

If ComboBox1.Text = "" Then

MsgBox "数量を選択してください。"

Exit Sub

End If

productName = ListBox1.List(ListBox1.ListIndex, 0)

unitPrice = ListBox1.List(ListBox1.ListIndex, 1)

amount = ComboBox1.Text

ListBox2.AddItem ""

ListBox2.List(ListBox2.ListCount - 1, 0) = productName

ListBox2.List(ListBox2.ListCount - 1, 1) = unitPrice

ListBox2.List(ListBox2.ListCount - 1, 2) = amount

ListBox2.List(ListBox2.ListCount - 1, 3) = CDec(unitPrice) * CDec(amount)

TotalPrice

End Sub

Sub TotalPrice()

result = 0

For r = 0 To ListBox2.ListCount - 1

result = CDec(result) + CDec(ListBox2.List(r, 3))

Next r

Label12.caption = "\ " & result

End Sub

2020-10-302020-11-04

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.Cursor = xlWait
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
    
End Sub

Sub Finalize()

Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Cursor = xlDefault
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.Cursor = xlWait

Application.EnableEvents = False

Application.DisplayAlerts = False

Application.Calculation = xlCalculationManual

End Sub

Sub Finalize()

Application.Calculation = xlCalculationAutomatic

Application.DisplayAlerts = True

Application.EnableEvents = True

Application.Cursor = xlDefault

Application.ScreenUpdating = True

End Sub

2020-09-09

VBA 並び替え

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

Sub test()

Set w = ActiveSheet

With w.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A1"), _
 Order:=xlDescending 'xlAscending
.SetRange w.Cells(1, 1).CurrentRegion
.Header = xlYes
.Apply
End With

End Sub

Sub test()

Set w = ActiveSheet

With w.Sort

.SortFields.Clear

.SortFields.Add Key:=Range("A1"), _

Order:=xlDescending 'xlAscending

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

.Header = xlYes

.Apply

End With

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://okamurax.com/"
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://okamurax.com/"

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

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

2019-12-172020-01-15

VBA 重複削除

重複を取り除く方法はいくつかあると思うけど、ネット上で一番有名なdictionaryを使う方法を採用。

Sub DeleteDuplicate()

Set dic = CreateObject("scripting.dictionary")

For Each r In Selection
  If Not dic.exists(r.Value) Then dic.Add r.Value, ""
Next

k = dic.keys
For i = 0 To dic.Count - 1
  Sheets("Sheet2").Cells(i + 1, 1).Value = k(i)
Next i

End Sub

Sub DeleteDuplicate()

Set dic = CreateObject("scripting.dictionary")

For Each r In Selection

If Not dic.exists(r.Value) Then dic.Add r.Value, ""

k = dic.keys

For i = 0 To dic.Count - 1

Sheets("Sheet2").Cells(i + 1, 1).Value = k(i)

Next i

End Sub

2019-12-112020-01-15

VBA 関数の参照先アドレス(行)の増減

大量の関数を複写や移動するとき、参照先アドレスの数値(行)だけ一括で増減したいときがある。

例えばデータ用のシートに対して印刷用のシートからの参照していて、行数の関係が対応していないためそのまま複写できない場合など。

今回は式の中にアドレスが1つだけの場合を想定している。

Sub AddSub()
 
sumValue = InputBox("行加算")
 
For Each cell In Selection
 
 targetRowValue = cell.Value ' sheet!A80
 
 If targetRowValue = "" Or Left(targetRowValue, 1) <> "#" Then GoTo brk
 
 tmp = InStr(targetRowValue, "!")
 targetAddress = Mid(targetRowValue, tmp + 1) ' A2
 targetSheetName = Left(targetRowValue, tmp) ' sheet!
 
 tmp = StrReverse(targetAddress & "9")
 tmp = Val(tmp)
 tmp = StrReverse(tmp)
 targetAddressNum = Left(tmp, Len(tmp) - 1) ' 2
 
 targetAddressAsc = Replace(targetAddress, targetAddressNum, "") ' A
  
 cell.Value = targetSheetName & targetAddressAsc & (0 + targetAddressNum + sumValue)
  
brk:
 
Next
 
End Sub

Sub AddSub()

sumValue = InputBox("行加算")

For Each cell In Selection

targetRowValue = cell.Value ' sheet!A80

If targetRowValue = "" Or Left(targetRowValue, 1) <> "#" Then GoTo brk

tmp = InStr(targetRowValue, "!")

targetAddress = Mid(targetRowValue, tmp + 1) ' A2

targetSheetName = Left(targetRowValue, tmp) ' sheet!

tmp = StrReverse(targetAddress & "9")

tmp = Val(tmp)

tmp = StrReverse(tmp)

targetAddressNum = Left(tmp, Len(tmp) - 1) ' 2

targetAddressAsc = Replace(targetAddress, targetAddressNum, "") ' A

cell.Value = targetSheetName & targetAddressAsc & (0 + targetAddressNum + sumValue)

brk:

End Sub

2019-11-202020-01-16

VBA フォルダ作成

以前フォルダの構成をエクセルに書き出す機能を作ってみた。

VBA フォルダ・ファイルのリンクの一覧

逆にエクセルからフォルダを作成できると便利という場面も多いので作ってみた。

Sub CreateFolder()

Set w = Sheets("表紙")

basePath = Application.ActiveWorkbook.Path

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

  targetPath = basePath & "\" & w.Cells(r, 1).Value
  
  If "" <> Dir(targetPath, vbDirectory) Then
    MsgBox w.Cells(r, 1).Value & "は既に存在します。"
    Exit Sub
  End If

r = r + 1
Loop

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

  targetPath = basePath & "\" & w.Cells(r, 1).Value
  If "" = Dir(targetPath, vbDirectory) Then MkDir (targetPath) ' 指定が重複してた場合
  
r = r + 1
Loop

MsgBox "完了しました。"

End Sub

Sub CreateFolder()

Set w = Sheets("表紙")

basePath = Application.ActiveWorkbook.Path

r = 1

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

targetPath = basePath & "\" & w.Cells(r, 1).Value

If "" <> Dir(targetPath, vbDirectory) Then

MsgBox w.Cells(r, 1).Value & "は既に存在します。"

Exit Sub

End If

r = r + 1

Loop

r = 1

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

targetPath = basePath & "\" & w.Cells(r, 1).Value

If "" = Dir(targetPath, vbDirectory) Then MkDir (targetPath) ' 指定が重複してた場合

r = r + 1

Loop

MsgBox "完了しました。"

End Sub

2019-08-162020-01-15

VBA 表から行

特定の範囲のデータをリスト化する場合、定番なのは行と列のループをネストさせる方法。

行の変数(r)と列(c)の変数をCellsで利用すればOK。見出し等は行や列の数値を固定にする。

Sub test()

Set fw = Sheets("f")
Set tw = Sheets("t")

tw.Cells.Delete
targetRow = 1
 
For c = 3 To 16
  For r = 3 To 258 Step 5
 
    staff = fw.Cells(r, 1).Value '列が固定の場合
    ym = fw.Cells(2, c).Value ' 行が固定の場合
    
    price1 = fw.Cells(r, c).Value
    price2 = fw.Cells(r + 1, c).Value
    note1 = fw.Cells(r + 2, c).Value
    note2 = fw.Cells(r + 3, c).Value
    note3 = fw.Cells(r + 4, c).Value
    
    tw.Cells(targetRow, 1).Value = staff
    tw.Cells(targetRow, 2).Value = ym
    tw.Cells(targetRow, 3).Value = price1
    tw.Cells(targetRow, 4).Value = price2
    tw.Cells(targetRow, 5).Value = note1
    tw.Cells(targetRow, 6).Value = note2
    tw.Cells(targetRow, 7).Value = note3
    
    targetRow = targetRow + 1
 
  Next r
Next c
 
End Sub

Sub test()

Set fw = Sheets("f")

Set tw = Sheets("t")

tw.Cells.Delete

targetRow = 1

For c = 3 To 16

For r = 3 To 258 Step 5

staff = fw.Cells(r, 1).Value '列が固定の場合

ym = fw.Cells(2, c).Value ' 行が固定の場合

price1 = fw.Cells(r, c).Value

price2 = fw.Cells(r + 1, c).Value

note1 = fw.Cells(r + 2, c).Value

note2 = fw.Cells(r + 3, c).Value

note3 = fw.Cells(r + 4, c).Value

tw.Cells(targetRow, 1).Value = staff

tw.Cells(targetRow, 2).Value = ym

tw.Cells(targetRow, 3).Value = price1

tw.Cells(targetRow, 4).Value = price2

tw.Cells(targetRow, 5).Value = note1

tw.Cells(targetRow, 6).Value = note2

tw.Cells(targetRow, 7).Value = note3

targetRow = targetRow + 1

Next r

Next c

End Sub

Sub test2()

r_start = 2
c_start = 3

r_count = 4
c_count = 5

l_start = 3

For r = r_start To r_start + r_count - 1
  For c = c_start To c_start + c_count - 1
    ActiveSheet.Cells(r, c).Value = r & "行" & ", " & c & "列"
  Next
Next

For r = r_start To r_start + r_count - 1
  For c = c_start To c_start + c_count - 1
    ActiveSheet.Cells(l_start, 1).Value = ActiveSheet.Cells(r, c).Value
    l_start = l_start + 1
  Next
Next

End Sub

Sub test2()

r_start = 2

c_start = 3

r_count = 4

c_count = 5

l_start = 3

For r = r_start To r_start + r_count - 1

For c = c_start To c_start + c_count - 1

ActiveSheet.Cells(r, c).Value = r & "行" & ", " & c & "列"

For r = r_start To r_start + r_count - 1

For c = c_start To c_start + c_count - 1

ActiveSheet.Cells(l_start, 1).Value = ActiveSheet.Cells(r, c).Value

l_start = l_start + 1

End Sub

2018-12-05

パス付きaccdbにエクセルVBAからアクセス

ちょっと試しに。

Sub MainRoutine(TargetName, BaseYear, RoutineType)

ExecuteResult = False

If RoutineType = "COMPARE_YEAR" Then

QueryString = "select * from xxx"
ExecuteResult = DbExecute(QueryString, TargetName, BaseYear, RoutineType)

End If

Call TmporaryDelete

If True = ExecuteResult Then
  MsgBox "完了しました"
Else
  MsgBox "エラーが発生しています"
End If

End Sub

Function DbExecute(QueryString, TargetName, BaseYear, RoutineType)

On Error GoTo e

Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

DbPath = "C:\xxx.accdb"
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & DbPath & "; Jet OLEDB:Database Password=xxx"

cn.Open ConnectionString
rs.Open QueryString, cn

If RoutineType = "COMPARE_YEAR" Then
  If False = CompareYear(rs, TargetName, BaseYear, RoutineType) Then GoTo e
End If

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

DbExecute = True
Exit Function

e:

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

DbExecute = False

End Function

Function CompareYear(ByVal rs, TargetName, BaseYear, RoutineType)

On Error GoTo e

Call TmporaryDelete
Set w = Sheets.Add: w.Name = "tmp"

SheetName = "年度比較(" & BaseYear - 1 & "-" & BaseYear & ")_" & TargetName

If True = ExistSheet(SheetName) Then
  MsgBox "シート名が重複しています"
  GoTo e
End If

Sheets("(雛形)年度比較").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = SheetName

'ActiveSheet.Cells(1, 1).CopyFromRecordset rs

CompareYear = True
Exit Function

e:

CompareYear = False

End Function

Function ExistSheet(SheetName)

For Each w In Sheets
  If w.Name = SheetName Then
    ExistSheet = True
    Exit Function
  End If
Next

ExistSheet = False

End Function

Sub TmporaryDelete()

Application.DisplayAlerts = False

For Each w In Sheets
  If w.Name = "tmp" Then Sheets("tmp").Delete
Next

Application.DisplayAlerts = True

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

Sub MainRoutine(TargetName, BaseYear, RoutineType)

ExecuteResult = False

If RoutineType = "COMPARE_YEAR" Then

QueryString = "select * from xxx"

ExecuteResult = DbExecute(QueryString, TargetName, BaseYear, RoutineType)

End If

Call TmporaryDelete

If True = ExecuteResult Then

MsgBox "完了しました"

Else

MsgBox "エラーが発生しています"

End If

End Sub

Function DbExecute(QueryString, TargetName, BaseYear, RoutineType)

On Error GoTo e

Set cn = CreateObject("ADODB.Connection")

Set rs = CreateObject("ADODB.Recordset")

DbPath = "C:\xxx.accdb"

ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & DbPath & "; Jet OLEDB:Database Password=xxx"

cn.Open ConnectionString

rs.Open QueryString, cn

If RoutineType = "COMPARE_YEAR" Then

If False = CompareYear(rs, TargetName, BaseYear, RoutineType) Then GoTo e

End If

If rs.State = 1 Then rs.Close

Set rs = Nothing

If cn.State = 1 Then cn.Close

Set cn = Nothing

DbExecute = True

Exit Function

If rs.State = 1 Then rs.Close

Set rs = Nothing

If cn.State = 1 Then cn.Close

Set cn = Nothing

DbExecute = False

End Function

Function CompareYear(ByVal rs, TargetName, BaseYear, RoutineType)

On Error GoTo e

Call TmporaryDelete

Set w = Sheets.Add: w.Name = "tmp"

SheetName = "年度比較(" & BaseYear - 1 & "-" & BaseYear & ")_" & TargetName

If True = ExistSheet(SheetName) Then

MsgBox "シート名が重複しています"

GoTo e

End If

Sheets("(雛形)年度比較").Copy After:=Sheets(Sheets.Count)

ActiveSheet.Name = SheetName

'ActiveSheet.Cells(1, 1).CopyFromRecordset rs

CompareYear = True

Exit Function

CompareYear = False

End Function

Function ExistSheet(SheetName)

For Each w In Sheets

If w.Name = SheetName Then

ExistSheet = True

Exit Function

End If

ExistSheet = False

End Function

Sub TmporaryDelete()

Application.DisplayAlerts = False

For Each w In Sheets

If w.Name = "tmp" Then Sheets("tmp").Delete

Application.DisplayAlerts = True

End Sub

2018-10-092020-05-10

VBA SQL実験用③(SQL Server)

以前作ったものにSELECT以外も動くように少し修正。SQLの動きを調べるのにエクセルからテーブルの作成やSQLの実行ができると楽。

Sub auto_open()

Application.CommandBars("cell").Reset

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

With Application.CommandBars("cell").Controls.Add
.OnAction = "e"
.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

Sub t()

Set cn = CreateObject("adodb.connection")
cn.Open "Provider=SQLOLEDB;Data Source=PC\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"

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

  Select Case Right(ActiveSheet.Cells(Selection(1).Row, c).Value, 1)
    Case "s"
    tmp = "varchar(255)"
    Case "i"
    tmp = "bigint"
    Case "m"
    tmp = "money"
    Case "d"
    tmp = "datetime"
  End Select
  
  fld = fld & ActiveSheet.Cells(Selection(1).Row, c).Value & " " & tmp & ","

Next c

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

q = "create table " & tbl & " (id integer identity(1,1) primary key," & fld & ")": Debug.Print q
cn.Execute 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 & ")": Debug.Print q
  cn.Execute q

  rec = ""
Next r

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

MsgBox "done"

End Sub

Sub s(q)

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

cn.Open "Provider=SQLOLEDB;Data Source=PC\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"
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 o(q)

Set cn = CreateObject("adodb.connection")

cn.Open "Provider=SQLOLEDB;Data Source=PC\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"
cn.Execute q

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

End Sub

Sub e()

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
  s (q)
Else
  o (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

Sub auto_open()

Application.CommandBars("cell").Reset

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

.OnAction = "t"

.Caption = "テーブル作成・登録"

End With

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

.OnAction = "e"

.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

Sub t()

Set cn = CreateObject("adodb.connection")

cn.Open "Provider=SQLOLEDB;Data Source=PC\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"

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

Select Case Right(ActiveSheet.Cells(Selection(1).Row, c).Value, 1)

Case "s"

tmp = "varchar(255)"

Case "i"

tmp = "bigint"

Case "m"

tmp = "money"

Case "d"

tmp = "datetime"

End Select

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

Next c

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

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

cn.Execute 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 & ")": Debug.Print q

cn.Execute q

rec = ""

Next r

If cn.State = 1 Then cn.Close

Set cn = Nothing

MsgBox "done"

End Sub

Sub s(q)

Set cn = CreateObject("adodb.connection")

Set rn = CreateObject("adodb.recordset")

cn.Open "Provider=SQLOLEDB;Data Source=PC\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"

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 o(q)

Set cn = CreateObject("adodb.connection")

cn.Open "Provider=SQLOLEDB;Data Source=PC\SQLEXPRESS;Initial Catalog=my_database;Integrated Security=SSPI;"

cn.Execute q

If cn.State = 1 Then cn.Close

Set cn = Nothing

End Sub

Sub e()

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

s (q)

Else

o (q)

End If

End Sub

2018-08-222020-01-15

VBA シート間のコピー

シート間のコピー

Sub Excute()

Set w = Sheets("マスタ登録用")

Dim hayStack As Range: Set hayStack = Sheets("品目マスタ").Range("D15:D8462")

For r = 3 To 3592
  
  If (r Mod 5) = 0 Then DoEvents
  
  productName = x(w.Cells(r, 1).Text)
  productNote = x(w.Cells(r, 4).Text)
  productItem = x(w.Cells(r, 5).Text)
  productKg = x(w.Cells(r, 24).Text)
  productLength = x(w.Cells(r, 25).Text)
  productWidth = x(w.Cells(r, 26).Text)
  productHeight = x(w.Cells(r, 27).Text)

  If productName <> "" Then Call Pour(hayStack, productName, productNote, productItem, productKg, productLength, productWidth, productHeight)

  Application.StatusBar = r

Next r

Application.StatusBar = False
MsgBox "done"

End Sub

Function x(target)
target = Replace(target, vbCrLf, "")
target = Replace(target, vbCr, "")
target = Replace(target, vbLf, "")
x = target
End Function

Sub Pour(hayStack, productName, productNote, productItem, productKg, productLength, productWidth, productHeight)

Set w = Sheets("品目マスタ")

For Each c In hayStack

  If (c.Text = productName) Then
    w.Cells(c.Row, 187) = productNote
    If productItem <> "" Then t = "1"
    w.Cells(c.Row, 179) = t
    w.Cells(c.Row, 180) = productKg
    w.Cells(c.Row, 181) = productLength
    w.Cells(c.Row, 182) = productWidth
    w.Cells(c.Row, 183) = productHeight
  End If

Next

End Sub

Sub Excute()

Set w = Sheets("マスタ登録用")

Dim hayStack As Range: Set hayStack = Sheets("品目マスタ").Range("D15:D8462")

For r = 3 To 3592

If (r Mod 5) = 0 Then DoEvents

productName = x(w.Cells(r, 1).Text)

productNote = x(w.Cells(r, 4).Text)

productItem = x(w.Cells(r, 5).Text)

productKg = x(w.Cells(r, 24).Text)

productLength = x(w.Cells(r, 25).Text)

productWidth = x(w.Cells(r, 26).Text)

productHeight = x(w.Cells(r, 27).Text)

If productName <> "" Then Call Pour(hayStack, productName, productNote, productItem, productKg, productLength, productWidth, productHeight)

Application.StatusBar = r

Next r

Application.StatusBar = False

MsgBox "done"

End Sub

Function x(target)

target = Replace(target, vbCrLf, "")

target = Replace(target, vbCr, "")

target = Replace(target, vbLf, "")

x = target

End Function

Sub Pour(hayStack, productName, productNote, productItem, productKg, productLength, productWidth, productHeight)

Set w = Sheets("品目マスタ")

For Each c In hayStack

If (c.Text = productName) Then

w.Cells(c.Row, 187) = productNote

If productItem <> "" Then t = "1"

w.Cells(c.Row, 179) = t

w.Cells(c.Row, 180) = productKg

w.Cells(c.Row, 181) = productLength

w.Cells(c.Row, 182) = productWidth

w.Cells(c.Row, 183) = productHeight

End If

End Sub

2018-06-262020-01-15

VBA 行数確認

各シートそれぞれ力技でループしていて随分時間がかかるなってときがある。特定の列が空白になるまでとか、Endなど特定の単語がでてくるまでとか、ループの判定の作り方は色々あるのだけれど、UsedRangeを安易に使って悪さしていることがあった。

シートを毎回VBAで作り直す処理なら問題ないけど、固定シートに入力してもらう場合CurrentRegionやUsedRangeは注意が必要ということ。

Sub test()

For Each w In Sheets
  Debug.Print w.Name, w.UsedRange.Rows.Count
Next

End Sub

Sub test()

For Each w In Sheets

Debug.Print w.Name, w.UsedRange.Rows.Count

End Sub

2018-03-232020-01-15

VBA フォルダの中にある全てのエクセルを開く

指定したフォルダ内にある全てのエクセルファイルを開いて値を持ってくる。意外にこれに近い動作を要望されることは多い。

ただこの方法、ファイルが上手く開けなかったりとか気をつけなければいけないことが多いので、なるべく採用しないようにしている。

Sub FileList()

Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")

p = "C:\test"

c = 1
For Each f In fs.GetFolder(p).Files
  Call MainProc(f.Path, c)
  c = c + 1
Next

End Sub

Function MainProc(p, c)

Workbooks.Open (p)
Set w = ActiveWorkbook

ThisWorkbook.Sheets("Sheet1").Cells(1, c).Value = w.Sheets("Sheet1").Cells(1, 1).Value

w.Close

End Function

Sub FileList()

Dim fs As Object

Set fs = CreateObject("Scripting.FileSystemObject")

p = "C:\test"

c = 1

For Each f In fs.GetFolder(p).Files

Call MainProc(f.Path, c)

c = c + 1

End Sub

Function MainProc(p, c)

Workbooks.Open (p)

Set w = ActiveWorkbook

ThisWorkbook.Sheets("Sheet1").Cells(1, c).Value = w.Sheets("Sheet1").Cells(1, 1).Value

w.Close

End Function

2018-01-25

VBA 日次チェックシート生成

Function holiday_chk(dt)

'通常の休日
If Weekday(dt) = 1 Or Weekday(dt) = 7 Then
  holiday_chk = True
  Exit Function
End If

'祝日
For r = 3 To 30
  If Sheets("表紙").Cells(r, 4).Value = dt Then
    holiday_chk = True
    Exit Function
  End If
Next r

holiday_chk = False

End Function
Private Sub CommandButton1_Click()

'入力チェック --------------------------------------------------------

If IsDate(Sheets("表紙").Cells(3, 2).Value) = False Then
  MsgBox "開始日が日付ではありません。"
  Exit Sub
End If

If IsDate(Sheets("表紙").Cells(6, 2).Value) = False Then
  MsgBox "終了日が日付ではありません。"
  Exit Sub
End If

If Sheets("表紙").Cells(3, 2).Value >= Sheets("表紙").Cells(6, 2).Value Then
  MsgBox "開始日と終了日の関係が正しくありません。"
  Exit Sub
End If

'ゴミ分別 --------------------------------------------------------

Sheets("ゴミ分別原本(雛形)").Copy after:=Sheets("表紙")
Set g = ActiveSheet

r = 7
dt = Sheets("表紙").Cells(3, 2).Value
Do While dt <= Sheets("表紙").Cells(6, 2).Value

  f = holiday_chk(dt)
  
  '表示形式
  If r = 7 Then
    g.Cells(r, 1).NumberFormatLocal = "yyyy/mm/dd"
  Else
    g.Cells(r, 1).NumberFormatLocal = "mm/dd"
  End If
  
  g.Cells(r, 3).NumberFormatLocal = "aaa"
  
  '配置
  g.Cells(r, 5).HorizontalAlignment = xlCenter
  g.Cells(r, 6).HorizontalAlignment = xlCenter
  g.Cells(r, 7).HorizontalAlignment = xlCenter
  g.Cells(r, 9).HorizontalAlignment = xlCenter
  
  '休日の場合
  If f = True Then g.Range(g.Cells(r, 1), g.Cells(r, 9)).Interior.Color = RGB(222, 222, 222)
  
  '罫線
  g.Range(g.Cells(r, 1), g.Cells(r, 9)).Borders.LineStyle = True
  
  '値
  g.Cells(r, 1).Value = dt '日付
  g.Cells(r, 3).Value = dt '曜日
  
  '休日では無い場合
  If f = False Then
    g.Cells(r, 5).Value = "○" '一般廃棄物ゴミ
    g.Cells(r, 6).Value = "○" '廃プラスチック類
    g.Cells(r, 7).Value = "○" '金属くず
    g.Cells(r, 8).Value = "" '備考
    tmp = Int((15 - 9 + 1) * Rnd + 9)
    g.Cells(r, 9).Value = Sheets("表紙").Cells(tmp, 2).Value 'チェック者
  End If
  
r = r + 1
dt = DateAdd("d", 1, dt)
Loop

'表題
g.Cells(2, 1).Value = "　　▼" & Sheets("表紙").Cells(18, 2).Value & "年廃棄物分別チェック表"

'作成日
For Each sh In g.Shapes
  If sh.Type = msoTextBox Then
    If sh.TextFrame.Characters.Text = "x" Then
      sh.TextFrame.Characters.Text = "作成日 " & Sheets("表紙").Cells(21, 2).Value
    End If
  End If
Next

'照明チェック --------------------------------------------------------

Sheets("照明チェック(雛形)").Copy after:=Sheets("表紙")
Set s = ActiveSheet

r = 9
dt = Sheets("表紙").Cells(3, 2).Value
Do While dt <= Sheets("表紙").Cells(6, 2).Value

  f = holiday_chk(dt)
  
  '表示形式
  If r = 9 Then
    s.Cells(r, 1).NumberFormatLocal = "yyyy/mm/dd"
  Else
    s.Cells(r, 1).NumberFormatLocal = "mm/dd"
  End If
  
  s.Cells(r, 3).NumberFormatLocal = "aaa"
  
  '配置
  s.Cells(r, 5).HorizontalAlignment = xlCenter
  s.Cells(r, 6).HorizontalAlignment = xlCenter
  s.Cells(r, 7).HorizontalAlignment = xlCenter
  s.Cells(r, 8).HorizontalAlignment = xlCenter
  s.Cells(r, 9).HorizontalAlignment = xlCenter
  s.Cells(r, 11).HorizontalAlignment = xlCenter
  
  '休日の場合
  If f = True Then s.Range(s.Cells(r, 1), s.Cells(r, 11)).Interior.Color = RGB(222, 222, 222)
  
  '罫線
  s.Range(s.Cells(r, 1), s.Cells(r, 11)).Borders.LineStyle = True
  
  '値
  s.Cells(r, 1).Value = dt '日付
  s.Cells(r, 3).Value = dt '曜日
  
  '休日では無い場合
  If f = False Then
    s.Cells(r, 5).Value = "○" '照明
    s.Cells(r, 6).Value = "○" '空調
    s.Cells(r, 7).Value = "○" 'マシン
    s.Cells(r, 8).Value = "○" 'ディスプレイ
    s.Cells(r, 9).Value = "○" 'プリンタ
    tmp = Int((15 - 9 + 1) * Rnd + 9)
    s.Cells(r, 11).Value = Sheets("表紙").Cells(tmp, 2).Value 'チェック者
  End If
  
r = r + 1
dt = DateAdd("d", 1, dt)
Loop

'表題
s.Cells(2, 1).Value = "　　▼" & Sheets("表紙").Cells(18, 2).Value & "年省エネチェック表"

'作成日
For Each sh In s.Shapes
  If sh.Type = msoTextBox Then
    If sh.TextFrame.Characters.Text = "x" Then
      sh.TextFrame.Characters.Text = "作成日 " & Sheets("表紙").Cells(21, 2).Value
    End If
  End If
Next

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

Function holiday_chk(dt)

'通常の休日

If Weekday(dt) = 1 Or Weekday(dt) = 7 Then

holiday_chk = True

Exit Function

End If

'祝日

For r = 3 To 30

If Sheets("表紙").Cells(r, 4).Value = dt Then

holiday_chk = True

Exit Function

End If

Next r

holiday_chk = False

End Function

Private Sub CommandButton1_Click()

'入力チェック --------------------------------------------------------

If IsDate(Sheets("表紙").Cells(3, 2).Value) = False Then

MsgBox "開始日が日付ではありません。"

Exit Sub

End If

If IsDate(Sheets("表紙").Cells(6, 2).Value) = False Then

MsgBox "終了日が日付ではありません。"

Exit Sub

End If

If Sheets("表紙").Cells(3, 2).Value >= Sheets("表紙").Cells(6, 2).Value Then

MsgBox "開始日と終了日の関係が正しくありません。"

Exit Sub

End If

'ゴミ分別 --------------------------------------------------------

Sheets("ゴミ分別原本(雛形)").Copy after:=Sheets("表紙")

Set g = ActiveSheet

r = 7

dt = Sheets("表紙").Cells(3, 2).Value

Do While dt <= Sheets("表紙").Cells(6, 2).Value

f = holiday_chk(dt)

'表示形式

If r = 7 Then

g.Cells(r, 1).NumberFormatLocal = "yyyy/mm/dd"

Else

g.Cells(r, 1).NumberFormatLocal = "mm/dd"

End If

g.Cells(r, 3).NumberFormatLocal = "aaa"

'配置

g.Cells(r, 5).HorizontalAlignment = xlCenter

g.Cells(r, 6).HorizontalAlignment = xlCenter

g.Cells(r, 7).HorizontalAlignment = xlCenter

g.Cells(r, 9).HorizontalAlignment = xlCenter

'休日の場合

If f = True Then g.Range(g.Cells(r, 1), g.Cells(r, 9)).Interior.Color = RGB(222, 222, 222)

'罫線

g.Range(g.Cells(r, 1), g.Cells(r, 9)).Borders.LineStyle = True

'値

g.Cells(r, 1).Value = dt '日付

g.Cells(r, 3).Value = dt '曜日

'休日では無い場合

If f = False Then

g.Cells(r, 5).Value = "○" '一般廃棄物ゴミ

g.Cells(r, 6).Value = "○" '廃プラスチック類

g.Cells(r, 7).Value = "○" '金属くず

g.Cells(r, 8).Value = "" '備考

tmp = Int((15 - 9 + 1) * Rnd + 9)

g.Cells(r, 9).Value = Sheets("表紙").Cells(tmp, 2).Value 'チェック者

End If

r = r + 1

dt = DateAdd("d", 1, dt)

Loop

'表題

g.Cells(2, 1).Value = "　　▼" & Sheets("表紙").Cells(18, 2).Value & "年廃棄物分別チェック表"

'作成日

For Each sh In g.Shapes

If sh.Type = msoTextBox Then

If sh.TextFrame.Characters.Text = "x" Then

sh.TextFrame.Characters.Text = "作成日 " & Sheets("表紙").Cells(21, 2).Value

End If

'照明チェック --------------------------------------------------------

Sheets("照明チェック(雛形)").Copy after:=Sheets("表紙")

Set s = ActiveSheet

r = 9

dt = Sheets("表紙").Cells(3, 2).Value

Do While dt <= Sheets("表紙").Cells(6, 2).Value

f = holiday_chk(dt)

'表示形式

If r = 9 Then

s.Cells(r, 1).NumberFormatLocal = "yyyy/mm/dd"

Else

s.Cells(r, 1).NumberFormatLocal = "mm/dd"

End If

s.Cells(r, 3).NumberFormatLocal = "aaa"

'配置

s.Cells(r, 5).HorizontalAlignment = xlCenter

s.Cells(r, 6).HorizontalAlignment = xlCenter

s.Cells(r, 7).HorizontalAlignment = xlCenter

s.Cells(r, 8).HorizontalAlignment = xlCenter

s.Cells(r, 9).HorizontalAlignment = xlCenter

s.Cells(r, 11).HorizontalAlignment = xlCenter

'休日の場合

If f = True Then s.Range(s.Cells(r, 1), s.Cells(r, 11)).Interior.Color = RGB(222, 222, 222)

'罫線

s.Range(s.Cells(r, 1), s.Cells(r, 11)).Borders.LineStyle = True

'値

s.Cells(r, 1).Value = dt '日付

s.Cells(r, 3).Value = dt '曜日

'休日では無い場合

If f = False Then

s.Cells(r, 5).Value = "○" '照明

s.Cells(r, 6).Value = "○" '空調

s.Cells(r, 7).Value = "○" 'マシン

s.Cells(r, 8).Value = "○" 'ディスプレイ

s.Cells(r, 9).Value = "○" 'プリンタ

tmp = Int((15 - 9 + 1) * Rnd + 9)

s.Cells(r, 11).Value = Sheets("表紙").Cells(tmp, 2).Value 'チェック者

End If

r = r + 1

dt = DateAdd("d", 1, dt)

Loop

'表題

s.Cells(2, 1).Value = "　　▼" & Sheets("表紙").Cells(18, 2).Value & "年省エネチェック表"

'作成日

For Each sh In s.Shapes

If sh.Type = msoTextBox Then

If sh.TextFrame.Characters.Text = "x" Then

sh.TextFrame.Characters.Text = "作成日 " & Sheets("表紙").Cells(21, 2).Value

End If

End Sub

2018-01-23

VBA 簡易承認機能

シートをパスワード保護し、そこに値を保存することで簡易的な承認機能を作成しようとした。実際に表示されている値と、保護された承認済みの値は起動時にチェックできるが、承認済みの値が見えないと使いづらいだろうと判断し別の方法を作成することにした。

Sub auto_open()

On Error Resume Next

'設定シート存在チェック

If sheets_exists = False Then Exit Sub

'コンテキスト削除

Application.CommandBars("cell").Controls("承認").Delete
Application.CommandBars("cell").Controls("承認").Delete

'コンテキスト初期化

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

  .Caption = "承認"
  
  With .Controls.Add
    .Caption = "承認①(" & Sheets("setting").Cells(3, 2).Value & ")"
    .OnAction = "'approval(3)'"
  End With
  
  With .Controls.Add
    .Caption = "承認②(" & Sheets("setting").Cells(4, 2).Value & ")"
    .OnAction = "'approval(4)'"
  End With

  With .Controls.Add
    .Caption = "承認③(" & Sheets("setting").Cells(5, 2).Value & ")"
    .OnAction = "'approval(5)'"
  End With

  With .Controls.Add
    .Caption = "承認④(" & Sheets("setting").Cells(6, 2).Value & ")"
    .OnAction = "'approval(6)'"
  End With
  
  With .Controls.Add
  
    .Caption = "設定"
    .OnAction = "setting"
    
  End With
  
End With

'起動チェック

On Error GoTo try

With Sheets("setting")

OnOff = UCase(.Cells(18, 2).Value)

If OnOff = "ON" Then

  s = .Cells(1, 2).Value
  
  'セル位置1
  r = .Cells(3, 2).Value
  If r <> "" Then
    v = Sheets(s).Range(r).Value
    If .Cells(8, 2).Value <> v Then MsgBox "承認されていません。#1"
  End If
  
  'セル位置2
  r = .Cells(4, 2).Value
  If r <> "" Then
    v = Sheets(s).Range(r).Value
    If .Cells(9, 2).Value <> v Then MsgBox "承認されていません。#2"
  End If
  
  'セル位置3
  r = .Cells(5, 2).Value
  If r <> "" Then
    v = Sheets(s).Range(r).Value
    If .Cells(10, 2).Value <> v Then MsgBox "承認されていません。#3"
  End If
  
  'セル位置4
  r = .Cells(6, 2).Value
  If r <> "" Then
    v = Sheets(s).Range(r).Value
    If .Cells(11, 2).Value <> v Then MsgBox "承認されていません。#3"
  End If
  
End If

End With

Exit Sub

try:

  MsgBox "起動時の承認が確認できませんでした"

End Sub

Sub auto_close()

On Error Resume Next

'コンテキスト削除

Application.CommandBars("cell").Controls("承認").Delete
Application.CommandBars("cell").Controls("承認").Delete

'設定シート保護

With Sheets("setting")

  .Visible = xlVeryHidden
  .Protect Password:="1234"
  
End With

End Sub

Sub setting()

'設定シート存在チェック

If sheets_exists = False Then Exit Sub

'表示されていたら非表示

If Sheets("setting").Visible = True Then

  With Sheets("setting")

    .Visible = xlVeryHidden
    .Protect Password:="1234"
  
  End With

  Exit Sub

End If

'管理者パスワードチェック

If admin_chk = False Then Exit Sub

With Sheets("setting")

'設定シート表示

  .Visible = True
  .Unprotect Password:="1234"

'アクティブ

  .Activate

End With

End Sub

Function sheets_exists()

i = False

For Each w In Sheets
  If w.Name = "setting" Then i = True
Next

If i = True Then

  sheets_exists = True
  
ElseIf i = False Then

  MsgBox "設定シートが存在しません。"
  sheets_exists = False
  
End If

End Function

Function admin_chk()

admin = "skthskth"
pw = InputBox("パスワードを入力してください")
If pw = "" Then Exit Function

If admin = pw Then

  admin_chk = True

ElseIf admin <> pw Then

  MsgBox "パスワードが正しくありません。"
  admin_chk = False

End If

End Function

Function app_pw_chk(p)

'sk4?0?

If Len(p) <> 6 Then GoTo e
If Left(p, 3) <> "sk4" Then GoTo e
If Mid(p, 5, 1) <> "0" Then GoTo e

app_pw_chk = True

Exit Function

e:

  MsgBox "承認パスワードが違います。"
  app_pw_chk = False

End Function

Sub approval(target_row)

'設定シート存在チェック

If sheets_exists = False Then Exit Sub

'承認パスワードチェック

p = InputBox("承認者パスワードを入力してください。")
If p = "" Then Exit Sub
If app_pw_chk(p) = False Then Exit Sub

'書き込み

On Error GoTo try

With Sheets("setting")
  
  .Unprotect Password:="1234"

  s = .Cells(1, 2).Value
  
  '承認
  r = .Cells(target_row, 2).Value
  If r = "" Then
    .Cells(target_row + 5, 2).Value = ""
  ElseIf r <> "" Then
    .Cells(target_row + 5, 2).Value = Sheets(s).Range(r).Value
  End If
  
  '承認者
  .Cells(target_row + 10, 2).Value = p
  
  .Protect Password:="1234"
  
End With

Exit Sub

try:

  MsgBox "承認処理が正しく実行されませんでした。"

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

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

Sub auto_open()

On Error Resume Next

'設定シート存在チェック

If sheets_exists = False Then Exit Sub

'コンテキスト削除

Application.CommandBars("cell").Controls("承認").Delete

'コンテキスト初期化

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

.Caption = "承認"

With .Controls.Add

.Caption = "承認①(" & Sheets("setting").Cells(3, 2).Value & ")"

.OnAction = "'approval(3)'"

End With

With .Controls.Add

.Caption = "承認②(" & Sheets("setting").Cells(4, 2).Value & ")"

.OnAction = "'approval(4)'"

End With

With .Controls.Add

.Caption = "承認③(" & Sheets("setting").Cells(5, 2).Value & ")"

.OnAction = "'approval(5)'"

End With

With .Controls.Add

.Caption = "承認④(" & Sheets("setting").Cells(6, 2).Value & ")"

.OnAction = "'approval(6)'"

End With

With .Controls.Add

.Caption = "設定"

.OnAction = "setting"

End With

'起動チェック

On Error GoTo try

With Sheets("setting")

OnOff = UCase(.Cells(18, 2).Value)

If OnOff = "ON" Then

s = .Cells(1, 2).Value

'セル位置1

r = .Cells(3, 2).Value

If r <> "" Then

v = Sheets(s).Range(r).Value

If .Cells(8, 2).Value <> v Then MsgBox "承認されていません。#1"

End If

'セル位置2

r = .Cells(4, 2).Value

If r <> "" Then

v = Sheets(s).Range(r).Value

If .Cells(9, 2).Value <> v Then MsgBox "承認されていません。#2"

End If

'セル位置3

r = .Cells(5, 2).Value

If r <> "" Then

v = Sheets(s).Range(r).Value

If .Cells(10, 2).Value <> v Then MsgBox "承認されていません。#3"

End If

'セル位置4

r = .Cells(6, 2).Value

If r <> "" Then

v = Sheets(s).Range(r).Value

If .Cells(11, 2).Value <> v Then MsgBox "承認されていません。#3"

End If

End With

Exit Sub

try:

MsgBox "起動時の承認が確認できませんでした"

End Sub

Sub auto_close()

On Error Resume Next

'コンテキスト削除

Application.CommandBars("cell").Controls("承認").Delete

'設定シート保護

With Sheets("setting")

.Visible = xlVeryHidden

.Protect Password:="1234"

End With

End Sub

Sub setting()

'設定シート存在チェック

If sheets_exists = False Then Exit Sub

'表示されていたら非表示

If Sheets("setting").Visible = True Then

With Sheets("setting")

.Visible = xlVeryHidden

.Protect Password:="1234"

End With

Exit Sub

End If

'管理者パスワードチェック

If admin_chk = False Then Exit Sub

With Sheets("setting")

'設定シート表示

.Visible = True

.Unprotect Password:="1234"

'アクティブ

.Activate

End With

End Sub

Function sheets_exists()

i = False

For Each w In Sheets

If w.Name = "setting" Then i = True

If i = True Then

sheets_exists = True

ElseIf i = False Then

MsgBox "設定シートが存在しません。"

sheets_exists = False

End If

End Function

Function admin_chk()

admin = "skthskth"

pw = InputBox("パスワードを入力してください")

If pw = "" Then Exit Function

If admin = pw Then

admin_chk = True

ElseIf admin <> pw Then

MsgBox "パスワードが正しくありません。"

admin_chk = False

End If

End Function

Function app_pw_chk(p)

'sk4?0?

If Len(p) <> 6 Then GoTo e

If Left(p, 3) <> "sk4" Then GoTo e

If Mid(p, 5, 1) <> "0" Then GoTo e

app_pw_chk = True

Exit Function

MsgBox "承認パスワードが違います。"

app_pw_chk = False

End Function

Sub approval(target_row)

'設定シート存在チェック

If sheets_exists = False Then Exit Sub

'承認パスワードチェック

p = InputBox("承認者パスワードを入力してください。")

If p = "" Then Exit Sub

If app_pw_chk(p) = False Then Exit Sub

'書き込み

On Error GoTo try

With Sheets("setting")

.Unprotect Password:="1234"

s = .Cells(1, 2).Value

'承認

r = .Cells(target_row, 2).Value

If r = "" Then

.Cells(target_row + 5, 2).Value = ""

ElseIf r <> "" Then

.Cells(target_row + 5, 2).Value = Sheets(s).Range(r).Value

End If

'承認者

.Cells(target_row + 10, 2).Value = p

.Protect Password:="1234"

End With

Exit Sub

try:

MsgBox "承認処理が正しく実行されませんでした。"

End Sub

2017-11-202017-11-21

VBA セル内の数式一覧

セル内で使われている数式を抜き出す。

シート１枚ずつ。

Sub test()

Set s1 = ActiveSheet

Sheets.Add after:=s1: Set s2 = ActiveSheet

For r = 1 To s1.UsedRange.Rows.Count
  For c = 1 To s1.UsedRange.Columns.Count
    If InStr(s1.Cells(r, c).Formula, "=") > 0 Then s2.Cells(r, c).Value = "'" & s1.Cells(r, c).Formula
  Next c
Next r

End Sub

Sub test()

Set s1 = ActiveSheet

Sheets.Add after:=s1: Set s2 = ActiveSheet

For r = 1 To s1.UsedRange.Rows.Count

For c = 1 To s1.UsedRange.Columns.Count

If InStr(s1.Cells(r, c).Formula, "=") > 0 Then s2.Cells(r, c).Value = "'" & s1.Cells(r, c).Formula

Next c

Next r

End Sub

全てのシート。

Sub test()
Sheets.Add after:=ActiveSheet
Set d = ActiveSheet
i = 1
For Each w In Sheets
  If w.Name <> d.Name Then
    For r = 1 To w.UsedRange.Rows.Count
      For c = 1 To w.UsedRange.Columns.Count
        If InStr(w.Cells(r, c).Formula, "=") > 0 Then
          d.Cells(i, 1).Value = "'" & w.Cells(r, c).Formula
          d.Cells(i, 2).Value = "'" & w.Name
          i = i + 1
        End If
      Next c
    Next r
  End If
Next
End Sub

Sub test()

Sheets.Add after:=ActiveSheet

Set d = ActiveSheet

i = 1

For Each w In Sheets

If w.Name <> d.Name Then

For r = 1 To w.UsedRange.Rows.Count

For c = 1 To w.UsedRange.Columns.Count

If InStr(w.Cells(r, c).Formula, "=") > 0 Then

d.Cells(i, 1).Value = "'" & w.Cells(r, c).Formula

d.Cells(i, 2).Value = "'" & w.Name

i = i + 1

End If

Next c

Next r

End If

End Sub

2017-11-152017-11-15

VBA 弥生CSV操作

DBに登録。

Application.StatusBar = "データアップロード中..."

On Error GoTo try

Set con = CreateObject("adodb.connection")

con.Open "provider=microsoft.jet.oledb.4.0;data source=" & ActiveWorkbook.Path & "\yayoi.mdb"
con.Execute "delete from tbl"

Set w = Sheets("貼付")

For r = 9 To w.UsedRange.Rows.Count

  If w.Cells(r, 1).Value = "[明細行]" Then

    w.Cells(r, 2).NumberFormatLocal = "yyyy/mm/dd"

    If w.Cells(r, 15).Text = "" Then w.Cells(r, 15).Value = 0
    If w.Cells(r, 16).Text = "" Then w.Cells(r, 16).Value = 0
    If w.Cells(r, 22).Text = "" Then w.Cells(r, 22).Value = 0
    If w.Cells(r, 23).Text = "" Then w.Cells(r, 23).Value = 0

    q = "insert into tbl (" & _
    "日付,借方勘定科目,借方補助科目,借方部門,借方金額,借方税額,貸方勘定科目,貸方補助科目,貸方部門,貸方金額,貸方税額,摘要" & _
    ") values (" & _
    "'" & w.Cells(r, 2).Text & "'," & _
    "'" & w.Cells(r, 10).Text & "'," & _
    "'" & w.Cells(r, 11).Text & "'," & _
    "'" & w.Cells(r, 12).Text & "'," & _
    " " & w.Cells(r, 15).Text & " ," & _
    " " & w.Cells(r, 16).Text & " ," & _
    "'" & w.Cells(r, 17).Text & "'," & _
    "'" & w.Cells(r, 18).Text & "'," & _
    "'" & w.Cells(r, 19).Text & "'," & _
    " " & w.Cells(r, 22).Text & " ," & _
    " " & w.Cells(r, 23).Text & " ," & _
    "'" & w.Cells(r, 24).Text & "');"

    con.Execute q: Debug.Print q

  End If

Next r

If con.State = 1 Then con.Close

Application.StatusBar = False

InsertDb = True

Exit Function

try:

  If con.State = 1 Then con.Close
  
  Application.StatusBar = False
  
  MsgBox Err.Description
  
  InsertDb = False

Application.StatusBar = "データアップロード中..."

On Error GoTo try

Set con = CreateObject("adodb.connection")

con.Open "provider=microsoft.jet.oledb.4.0;data source=" & ActiveWorkbook.Path & "\yayoi.mdb"

con.Execute "delete from tbl"

Set w = Sheets("貼付")

For r = 9 To w.UsedRange.Rows.Count

If w.Cells(r, 1).Value = "[明細行]" Then

w.Cells(r, 2).NumberFormatLocal = "yyyy/mm/dd"

If w.Cells(r, 15).Text = "" Then w.Cells(r, 15).Value = 0

If w.Cells(r, 16).Text = "" Then w.Cells(r, 16).Value = 0

If w.Cells(r, 22).Text = "" Then w.Cells(r, 22).Value = 0

If w.Cells(r, 23).Text = "" Then w.Cells(r, 23).Value = 0

q = "insert into tbl (" & _

"日付,借方勘定科目,借方補助科目,借方部門,借方金額,借方税額,貸方勘定科目,貸方補助科目,貸方部門,貸方金額,貸方税額,摘要" & _

") values (" & _

"'" & w.Cells(r, 2).Text & "'," & _

"'" & w.Cells(r, 10).Text & "'," & _

"'" & w.Cells(r, 11).Text & "'," & _

"'" & w.Cells(r, 12).Text & "'," & _

" " & w.Cells(r, 15).Text & " ," & _

" " & w.Cells(r, 16).Text & " ," & _

"'" & w.Cells(r, 17).Text & "'," & _

"'" & w.Cells(r, 18).Text & "'," & _

"'" & w.Cells(r, 19).Text & "'," & _

" " & w.Cells(r, 22).Text & " ," & _

" " & w.Cells(r, 23).Text & " ," & _

"'" & w.Cells(r, 24).Text & "');"

con.Execute q: Debug.Print q

End If

Next r

If con.State = 1 Then con.Close

Application.StatusBar = False

InsertDb = True

Exit Function

try:

If con.State = 1 Then con.Close

Application.StatusBar = False

MsgBox Err.Description

InsertDb = False

DBから取り出す。

Application.StatusBar = "データ取得中..."

On Error GoTo try

Set con = CreateObject("adodb.connection")
Set rec = CreateObject("adodb.recordset")

con.Open "provider=microsoft.jet.oledb.4.0;data source=" & ActiveWorkbook.Path & "\yayoi.mdb"

Set w = Sheets("集計")
w.Activate
w.Cells.Delete

i = 1

w.Cells(i, 1).Value = "売上"

i = w.UsedRange.Rows.Count + 1
rec.Open "select '生産者売上高','-',sum(貸方金額)-sum(貸方税額) from tbl where 貸方勘定科目 = '生産者売上高'", con
w.Cells(i, 2).CopyFromRecordset rec
rec.Close

i = w.UsedRange.Rows.Count + 1
w.Cells(i, 1).Value = "売上/補助"

i = w.UsedRange.Rows.Count + 1
rec.Open "select '生産者売上高',貸方補助科目,sum(貸方金額)-sum(貸方税額) from tbl where 貸方勘定科目 = '生産者売上高' group by 貸方補助科目"
w.Cells(i, 2).CopyFromRecordset rec
rec.Close

w.Columns.AutoFit

If con.State = 1 Then con.Close

Application.StatusBar = False

SelectDb = True

Exit Function

try:

  If con.State = 1 Then con.Close
  
  Application.StatusBar = False
  
  MsgBox Err.Description
  
  SelectDb = False

Application.StatusBar = "データ取得中..."

On Error GoTo try

Set con = CreateObject("adodb.connection")

Set rec = CreateObject("adodb.recordset")

con.Open "provider=microsoft.jet.oledb.4.0;data source=" & ActiveWorkbook.Path & "\yayoi.mdb"

Set w = Sheets("集計")

w.Activate