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

2019-12-172021-07-29

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

少し違うバージョン

Sub DeleteDuplicate()
 
Set dic = CreateObject("scripting.dictionary")

Set w = ActiveSheet

For r = 2 To 4111

  k = w.Cells(r, 1).Value
  v = w.Cells(r, 2).Value

  If Not dic.exists(k) Then dic.Add k, v
  
Next

kk = dic.keys
vv = dic.items

For i = 0 To dic.Count - 1
  w.Cells(i + 1, 4).Value = kk(i)
  w.Cells(i + 1, 5).Value = vv(i)
Next i
 
End Sub

Sub DeleteDuplicate()

Set dic = CreateObject("scripting.dictionary")

Set w = ActiveSheet

For r = 2 To 4111

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

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

If Not dic.exists(k) Then dic.Add k, v

kk = dic.keys

vv = dic.items

For i = 0 To dic.Count - 1

w.Cells(i + 1, 4).Value = kk(i)

w.Cells(i + 1, 5).Value = vv(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

VBA パス付きAccess(accdb)にアクセス

ちょっと試しに。

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 フォルダの中にある全てのExcelを開く

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

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

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