| |
▼ponpon さん：
アドバイスを参考にさせていただき、やりたいことに一歩近づくことができました。
またしても変更しなければいけない点がでてきたのですが、整理してから質問します。
とりあえずどうもありがとうございました。
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 False
Case r Mod 23 = 11 Or r Mod 23 = 16
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
Case Else
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
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/6/30(木) 17:21 -
