| |
▼マナ さん：
>それを提示してください。
色々編集して現在は下記の通り。
以前ほどには処理に時間がかからなくなった気がします。
ただ、
(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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
