| |
ponponさんにお詫びですが、表出した人名の数カウントするという表現は正確でなく、人名に応じた○の数をカウントするというのが正確でした。もうしわけありませんでした。
やりたいことを正確に書きます。
まず、無条件に4箇所(E3,E11,E16,E21)に○をつけます。
その直後にF3の人名をカウンタとして使って+1し、
F11の人名をカウンタとして使って+1し、
F16の人名をカウンタとして使って+1し、
F21の人名をカウンタとして使って+1します。
その後、以下のパターンが続きます。
F26からF33の人名カウンタうち最も小さいE列のセルに○をつけ、かつ、
その人名カウンタに+1し、
F34からF38の人名カウンタうち最も小さいE列のセルに○をつけ、かつ、
その人名カウンタに+1し、
F39からF43の人名カウンタうち最も小さいE列のセルに○をつけ、かつ、
その人名カウンタに+1し、
F44からF48の人名カウンタうち最も小さいE列のセルに○をつけ、かつ、
その人名カウンタに+1します。
F49からF56の人名カウンタうち最も小さいE列のセルに○をつけ、かつ、
その人名カウンタに+1し、
F57からF61の人名カウンタうち最も小さいE列のセルに○をつけ、かつ、
その人名カウンタに+1し、
F62からF66の人名カウンタうち最も小さいE列のセルに○をつけ、かつ、
その人名カウンタに+1し、
F67からF71の人名カウンタうち最も小さいE列のセルに○をつけ、かつ、
その人名カウンタに+1します。
・・・このパターンが531行目に達するまで続きます。
このようにして人名に応じた○の数をなるべく平準化したいのです。
どう書けばよいかご教示ください。
Sub test()
Dim myR As Range
Dim myRow As Long
Dim c As Range
Dim myAry As Variant
Dim i As Long
Dim v As Variant
Dim lc As Long
Dim r As Long
Dim m As Long
Dim s As Long
Dim t As Long
Dim u As Long
Dim w As Long
Dim k As Long
Const lr As Long = 531
Dim rag As Range, FRw As Long
With ActiveSheet
If .Name = "営業日" Then
MsgBox "シフト表をアクティブにして実行する事。", 64
Exit Sub
End If
Application.ScreenUpdating = False
r = 3
i = 1
k = 1
m = 6
Do While r <= lr
Select Case r Mod 92
Case 11, 16, 34, 39, 57, 62
v = Worksheets("人員").Range("B2:B5").Value
.Cells(r, 6).Value = v(k, 1)
k = k + 1
If k > 4 Then k = 1
r = r + 1
Case Else
v = Worksheets("人員").Range("A2:A30").Value
.Cells(r, 6).Value = v(i, 1)
i = i + 1
If i > 29 Then i = 1
r = r + 1
End Select
Loop
Application.ScreenUpdating = True
End With
Application.ScreenUpdating = False
'ワークシート関数CountIfで各氏名の表出をカウントする。
Set myR = Range("F1", Range("F65536").End(xlUp))
myRow = Range("F65536").End(xlUp).Row
With myR.Offset(0, 3)
.Value = "=CountIf($F$1:$F$" & myRow & ", F1)"
.Value = .Value
End With
'E列の値を消す
Range("E3:E65536").ClearContents
'F3,F11,F16,F21の人に１ポイント追加し、
myAry = Array(Range("F3").Value, Range("F11").Value, Range("F16").Value, Range("F21").Value)
For i = 0 To 3
For Each c In myR
If c.Value = myAry(i) Then
With c
.Offset(0, 3).Value = .Offset(0, 3).Value + 1
End With
End If
Next
Next
'E3 , E11, E16, E21に○をつける
Range("E3 , E11, E16, E21").Value = "○"
'E26に○をつける
For s = 26 To 531 Step 23
With Cells(s, 5)
If .Offset(0, 4).Value > .Offset(1, 4).Value Then
.Offset(1, 0).Value = "○"
Else
.Value = "○"
End If
End With
Next
'E34に○をつける
For t = 34 To 531 Step 23
With Cells(t, 5)
If .Offset(0, 4).Value > .Offset(1, 4).Value Then
.Offset(1, 0).Value = "○"
Else
.Value = "○"
End If
End With
Next
'E39に○をつける
For u = 39 To 531 Step 23
With Cells(u, 5)
If .Offset(0, 4).Value > .Offset(1, 4).Value Then
.Offset(1, 0).Value = "○"
Else
.Value = "○"
End If
End With
Next
'E44に○をつける
For w = 44 To 531 Step 23
With Cells(w, 5)
If .Offset(0, 4).Value > .Offset(1, 4).Value Then
.Offset(1, 0).Value = "○"
Else
.Value = "○"
End If
End With
Next
'作業列の値を消す。
myR.Offset(0, 3).ClearContents
Application.ScreenUpdating = True
End Sub
|
|
にしもり
- 05/7/1(金) 13:57 -
