VBA – テックメモ

2019-11-20

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-16

VBA 表から行

Sub test()

Set tw = Sheets("2")
tw.Cells.Delete

Set fw = Sheets("1")

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

r = 1
Do While tw.Cells(r, 1).Value <> ""
  If tw.Cells(r, 5).Value = "" And tw.Cells(r, 6).Value = "" And tw.Cells(r, 7).Value = "" Then
    tw.Rows(r).Delete
    r = r - 1
  End If
r = r + 1
Loop

End Sub

Sub test()

Set tw = Sheets("2")

tw.Cells.Delete

Set fw = Sheets("1")

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

r = 1

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

If tw.Cells(r, 5).Value = "" And tw.Cells(r, 6).Value = "" And tw.Cells(r, 7).Value = "" Then

tw.Rows(r).Delete

r = r - 1

End If

r = r + 1

Loop

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-08-222018-08-22

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-26

VBA 行数確認

全シート力技でループしていて随分時間がかかるなってとき。

Sub test()

For Each w In Sheets

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

Next w

End Sub

Sub test()

For Each w In Sheets

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

Next w

End Sub

2018-03-23

VBA フォルダ以下のセルの値をコピー

Sub file_list()

p = ""
ThisWorkbook.Sheets("Sheet1").Cells(1, 1).Value = DateTime.Now

Dim fso As New FileSystemObject
For Each f In fso.GetFolder(p).Files
  If main_procedure(f.path) = False Then Exit Sub
Next

End Sub
Function main_procedure(p)

Workbooks.Open (p)
Set w = ActiveWorkbook

w.Sheets("Sheet1").Activate

r = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count

ThisWorkbook.Sheets("Sheet1").Range(ThisWorkbook.Sheets("Sheet1").Cells(r + 1, 1), ThisWorkbook.Sheets("Sheet1").Cells(r + 13, 18)).Value = _
w.Sheets("Sheet1").Range("A36:Q48").Value

ThisWorkbook.Sheets("Sheet1").Cells(r + 1, 1).Value = w.Name

w.Close
main_procedure = True

End Function

Sub file_list()

p = ""

ThisWorkbook.Sheets("Sheet1").Cells(1, 1).Value = DateTime.Now

Dim fso As New FileSystemObject

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

If main_procedure(f.path) = False Then Exit Sub

End Sub

Function main_procedure(p)

Workbooks.Open (p)

Set w = ActiveWorkbook

w.Sheets("Sheet1").Activate

r = ThisWorkbook.Sheets("Sheet1").UsedRange.Rows.Count

ThisWorkbook.Sheets("Sheet1").Range(ThisWorkbook.Sheets("Sheet1").Cells(r + 1, 1), ThisWorkbook.Sheets("Sheet1").Cells(r + 13, 18)).Value = _

w.Sheets("Sheet1").Range("A36:Q48").Value

ThisWorkbook.Sheets("Sheet1").Cells(r + 1, 1).Value = w.Name

w.Close

main_procedure = True

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

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

該当アドレスを取り出す。

Set w = Sheets("集計")
  
For r = 1 To w.UsedRange.Rows.Count

  If w.Cells(r, 2).Text = op1 And w.Cells(r, 3).Text = op2 Then
  
    SearchText = w.Cells(r, 4).Address(rowabsolute:=False, columnabsolute:=False)
    Exit Function
  
  End If
  
Next r

SearchText = "A2"

Set w = Sheets("集計")

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

If w.Cells(r, 2).Text = op1 And w.Cells(r, 3).Text = op2 Then

SearchText = w.Cells(r, 4).Address(rowabsolute:=False, columnabsolute:=False)

Exit Function

End If

Next r

SearchText = "A2"

関数登録

w.Cells(13, 5).Value = "=集計!" & SearchText("業者仕入高", "加工他（買取）")

1	w.Cells(13, 5).Value = "=集計!" & SearchText("業者仕入高", "加工他（買取）")