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