セルを判定し背景色を自動でセットする【数値指定】

対象セルの値を判定して、背景色を自動でセットするツールです。

テスト結果などの点数や、金額など数値データが大量にある時、自動でまとめて背景色を設定することができます。

氏名や住所など文字条件を指定したい場合は、セルを判定し背景色を自動でセットする【文字指定】のプログラムを使ってください。

画面・基本機能

対象のシートとセルのエリアを指定できます。
条件を数値で範囲指定(50~80など)できます。
セットする背景色を選べます。

使い方

１．対象となるファイルの情報を入力します

①のエリアに背景色をセットするファイルの情報を入力します。

フルパスでファイル名
シート名(未入力時は1番左のシートが対象)
セルの範囲

ファイル名は、横の[参照ボタン]をクリックして選ぶことができます。

２．背景色を変更する条件を入力します

背景色を変更するセルの値を指定します。

[セットする背景色]の背景色を変更すると、プログラムでセットする背景色も変化します。

条件で60~79は緑、80~100は青などパターン分けし、連続して使うことができます。

３．実行ボタンをクリックすると、背景色がセットされます

実行後、対象のエクセルファイルに背景色がセットされ、件数も表示されます。

ダウンロード

バージョン：1.0
更新日　　：2019/02/01

プログラムとテストデータがダウンロードできます。

＞ダウンロード

プログラム

便利ツールとして使いたいだけであれば、とくにプログラムの中身は読まなくて大丈夫です。

中身も確認したい、勉強したい人は見てください。

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

264

265

266

267

268

269

270

271

272

273

274

275

276

277

Option Explicit

'***********************************************************************

'*　背景色セットプログラム

'*　2019/02/05　新規作成　えくとしょ(https://excel-toshokan.com/)

'***********************************************************************

'////////////////////////////////////////////////////////////////

' 定数定義エリア

'////////////////////////////////////////////////////////////////

'セル位置

Private Const CELL_FILE_NM = "D10" 'ファイル名

Private Const CELL_SHEET_NM = "D14" 'シート名

Private Const CELL_HANNI_FROM = "D18" 'セル範囲

Private Const CELL_HANNI_TO = "F18" '

Private Const CELL_JOKEN_FROM = "D23" 'セルの値

Private Const CELL_JOKEN_TO = "F23"

Private Const CELL_BACKCOLOR = "D27" 'セットする背景色

'////////////////////////////////////////////////////////////////

' イベント定義エリア

'////////////////////////////////////////////////////////////////

'******************************************************

'ファイル参照ダイアログ_クリック

'******************************************************

Private Sub cmdFileOpen_Click()

Dim openFileName As String

'ダイアログ表示

openFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")

'ファイル選択時、シートの入力エリアにセット

If openFileName <> "False" Then

Me.Range(CELL_FILE_NM).Value = openFileName

End If

End Sub

'******************************************************

'実行ボタン_クリック

'******************************************************

Private Sub cmdExec_Click()

On Error GoTo ErrProc

Dim cnt As Long

'-------------------------

'入力チェック

'-------------------------

If CheckInput = False Then

Exit Sub

End If

'-------------------------

'確認メッセージ

'-------------------------

If MsgBox("背景色セット処理を実行しますか？", vbQuestion + vbYesNo) = vbNo Then

Exit Sub

End If

'-------------------------

'メイン処理実行

'-------------------------

cnt = MainProc

'-------------------------

'終了処理

'-------------------------

MsgBox "完了しました。" & vbCrLf & "背景色をセットしたセルの数：" & cnt, vbInformation

Exit Sub

ErrProc:

'エラー処理

Dim strErrMsg As String

strErrMsg = ""

strErrMsg = strErrMsg & "エラーが発生しました。" & vbCrLf

strErrMsg = strErrMsg & "【エラー番号】" & Err.Number & vbCrLf

strErrMsg = strErrMsg & "【エラー内容】" & Err.Description & vbCrLf

MsgBox strErrMsg, vbCritical

End Sub

'////////////////////////////////////////////////////////////////

' 関数定義エリア

'////////////////////////////////////////////////////////////////

'******************************************************

'関数名　：入力チェック

'処理内容：ユーザの入力内容をチェックし、結果を返す

'　　　　：最低限のチェックのみ

'戻り値　：True　エラーなし

'　　　　：False エラーあり

'******************************************************

Private Function CheckInput() As Boolean

CheckInput = False

'-------------------------

'ファイル名

'-------------------------

'必須チェック

If Trim(Me.Range(CELL_FILE_NM).Value) = "" Then

MsgBox "背景色をセットするセルの値を入力してください。", vbExclamation + vbOKOnly

Exit Function

End If

'存在チェック

If Dir(Me.Range(CELL_FILE_NM).Value) = "" Then

MsgBox "ファイルが存在しません。", vbExclamation + vbOKOnly

Exit Function

End If

'-------------------------

'シート名

'-------------------------

'チェックなし

'-------------------------

'セル範囲

'-------------------------

'必須チェック

If Trim(Me.Range(CELL_HANNI_FROM).Value) = "" Then

MsgBox "セル範囲の開始位置を入力してください。", vbExclamation + vbOKOnly

Exit Function

End If

'必須チェック

If Trim(Me.Range(CELL_HANNI_TO).Value) = "" Then

MsgBox "セル範囲の終了位置を入力してください。", vbExclamation + vbOKOnly

Exit Function

End If

'-------------------------

'セルの値

'-------------------------

'必須チェック

If Trim(Me.Range(CELL_JOKEN_FROM).Value) = "" Then

MsgBox "背景色をセットするセルの値(最小値)を入力してください。", vbExclamation + vbOKOnly

Exit Function

End If

If Trim(Me.Range(CELL_JOKEN_TO).Value) = "" Then

MsgBox "背景色をセットするセルの値(最大値)を入力してください。", vbExclamation + vbOKOnly

Exit Function

End If

'数値チェック

If IsNumeric(Me.Range(CELL_JOKEN_FROM).Value) = False Then

MsgBox "セルの値(最小値)には、数値を入力してください。", vbExclamation + vbOKOnly

Exit Function

End If

If IsNumeric(Me.Range(CELL_JOKEN_TO).Value) = False Then

MsgBox "セルの値(最大値)には、数値を入力してください。", vbExclamation + vbOKOnly

Exit Function

End If

'エラーなし

CheckInput = True

End Function

'******************************************************

'関数名　：メイン処理

'処理内容：

'******************************************************

Private Function MainProc() As Long

'-------------------------

'変数定義(入力シート取得用)

'-------------------------

Dim tFile As Workbook '対象ファイル

Dim tSheetNm As String '対象シート名

Dim tCellHani As String '対象セル範囲

Dim tCell As Range '対象セル

Dim cellMin As Double 'セルの最小値

Dim cellMax As Double 'セルの最大値

'-------------------------

'対象ファイルを取得

'-------------------------

Dim fileNm As String 'ファイル名取得

fileNm = GetFileName(Me.Range(CELL_FILE_NM).Value)

On Error Resume Next

'※簡易チェックとする

Set tFile = Workbooks(fileNm)

If Err.Number > 0 Then

Err.Clear

'開いていない時は、対象ファイルを開く

Set tFile = Workbooks.Open(Me.Range(CELL_FILE_NM).Value)

End If

On Error GoTo 0

'-------------------------

'入力シートの内容を取得

'-------------------------

'シート名設定

If Trim(Me.Range(CELL_SHEET_NM).Value) = "" Then

tSheetNm = tFile.Worksheets(1).Name

Else

tSheetNm = Me.Range(CELL_SHEET_NM).Value

End If

'対象セル範囲

tCellHani = Me.Range(CELL_HANNI_FROM).Value & ":" & Me.Range(CELL_HANNI_TO).Value

'判定値をセット

cellMin = CDbl(Me.Range(CELL_JOKEN_FROM))

cellMax = CDbl(Me.Range(CELL_JOKEN_TO))

'-------------------------

'背景色セット処理

'-------------------------

Dim cnt As Long '処理件数カウント用

cnt = 0

Application.ScreenUpdating = False '描画停止

'対象範囲をチェック

For Each tCell In tFile.Worksheets(tSheetNm).Range(tCellHani)

If IsNumeric(tCell.Value) = True Then

If CDbl(tCell.Value) >= cellMin And CDbl(tCell.Value) <= cellMax Then

'範囲内の時、背景色をセット

tCell.Interior.Color = Me.Range(CELL_BACKCOLOR).Interior.Color

'処理件数カウント

cnt = cnt + 1

End If

tFile.Worksheets(tSheetNm).Activate

Application.ScreenUpdating = True '描画

'背景色をセットした件数を返す

MainProc = cnt

End Function

'******************************************************

'関数名　：ファイル名取得

'処理内容：フルパスからファイル名を取得し返す

'戻り値　：ファイル名

'******************************************************

Private Function GetFileName(ByVal fileFullPath As String) As String

Dim fso As Object

Set fso = CreateObject("Scripting.FileSystemObject")

'ファイルの取得

Dim fileObject As Object

Set fileObject = fso.GetFile(fileFullPath)

'引数からファイル名を取得

GetFileName = fileObject.Name

' 後始末

Set fso = Nothing

End Function