Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

207 / 76616

←次へ　｜　前へ→


	【82076】Re:色付きセル＆数値入りセルの個数を数えたい

へっぽこです - 22/10/14(金) 7:11 -


	引用なし

	パスワード

▼マナさん：

>それを提示してください。

色々編集して現在は下記の通り。
以前ほどには処理に時間がかからなくなった気がします。

ただ、
(1)とても泥臭い処理を行っている気がします。
(2)連続作業番号削除がどんな場面でも正確に処理されるのか、が気になっています。

もっとスマートな方法があればご教授ください。

Function CountCcolorText(range_data As Range, criteriaC As Range, criteriaT As Range) As Long '指定した色のセル数_and_指定した文字セルのカウント
Dim datax As Range
Dim xcolor As Long
Dim xtext As String

Application.Volatile
CountCcolorText = 0

xcolor = criteriaC.Interior.ColorIndex
xtext = criteriaT.Value

For Each datax In range_data
　 If datax.Interior.ColorIndex = xcolor And datax.Value = xtext Then
　　 CountCcolorText = CountCcolorText + 1
　 End If
Next datax
End Function

Sub 作業番号連続コピー()
　 Sheets("月間ユニット集計").Activate
'***********************************************************************
'色の付いているセルだけを選択する
　　For Each rng In Range("R11:DI41")
　　　If rng.Interior.ColorIndex <> xlNone Then　'セルに色が付いている場合
　　　　If selectRng Is Nothing Then '最初にヒットした場合
　　　　　Set selectRng = rng
　　　　Else
　　　　　Set selectRng = Application.Union(selectRng, rng) '色が付いているセルを選択範囲に追加していく
　　　　End If
　　　End If
　　Next rng
'***********************************************************************
'作業番号コピー
　　For Each rng In selectRng　'着色セル範囲内で
　　　If rng <> "" And rng.Offset(0, 1).Interior.ColorIndex <> xlNone And rng.Offset(0, 1) = "" Then 'セルに文字があり隣のセルが着色され,隣のセルが空欄の場合
　　　　rng.Offset(0, 1).Value = rng
　　　ElseIf rng = "" And rng.Interior.ColorIndex <> xlNone Then 'セルに文字が無くセルが着色されている場合
　　　　rng = rng.End(xlToLeft)
　　　End If

　　　If rng = Cells(rng.Row, "F") Or rng = Cells(rng.Row, "H") Or rng = Cells(rng.Row, "J") Or rng = Cells(rng.Row, "L") Or rng = Cells(rng.Row, "N") Or rng = Cells(rng.Row, "P") Then '列F,H,J,L,N,Pには別数値設定済
　　　　rng.ClearContents
　　　End If
　　Next rng
'***********************************************************************
'着色セルand数値セル集計
　　For iR = 50 To 69
　　　If Cells(iR, 1) <> "" Then
　　　　For iC = 6 To 14 Step 2
　　　　　Cells(iR, iC) = CountCcolorText(selectRng, Cells(48, iC), Cells(iR, 1)) 'セル(48, iC)には時間区分毎の設定色がせっていされています。
　　　　Next iC
'無着色セルand数値セル集計
　　　　Cells(iR, 16) = CountCcolorText(Range("R11:DI41"), Cells(48, 16), Cells(iR, 1)) 'セル(iR, 16)は作業番号有り、かつ無着色エラーの検出用。
　　　End If
　　Next iR
End Sub

Sub 連続作業番号削除()
Application.ScreenUpdating = False
　 Sheets("月間ユニット集計").Activate
　　 For iC = 113 To 18 Step -1
　　　 For iR = 11 To 41
　　　　 If Cells(iR, iC) = Cells(iR, iC - 1) Then
　　　　　 Cells(iR, iC).ClearContents
　　　　 End If
　　　　 If Cells(iR, iC) <> "" And Cells(iR, iC - 1) = "" And Cells(iR, iC) = Cells(iR, iC).End(xlToLeft) Then
　　　　　 Cells(iR, iC).ClearContents
　　　　 End If
　　　 Next iR
　　 Next iC
End Sub

43 hits

▼

【82073】色付きセル＆数値入りセルの個数を数えたい へっぽこです 22/10/13(木) 8:40