| |
hiro さん、おはようございます。
>もう少し質問させて頂きたいのですが レイアウトを変更したく思いましてシート2のB2から部署名を入れて出力データをC列から表示したいのですが修正箇所を教えていただけないでしょうか？それと一部署の人数が10人以上になったときの修正箇所も教えて頂けないでしょうか？
応用しやすいように、変数で変更するようにしました。
Sub test()
Dim ws(1 To 2) As Worksheet, r(1 To 3) As Range
Dim Cmax As Long, Cp As Long, Rp As Long, Dp As String
Dim dt As Long, Rmax As Long, Rpos As Long, RR As Long, msg As String
'転記先の設定いろいろ
Cmax = 10 '最大人数
Cp = 2 '転記先の部署の入った列(B列=>2)
Rp = 2 '転記先の行の開始番号(2行目)
Dp = "K1" '日付指定セル
'
With Application.ThisWorkbook
Set ws(1) = .Worksheets("Sheet1") '元
Set ws(2) = .Worksheets("Sheet2") '先
End With
'一覧表の範囲設定(部署名一覧を取得)
With ws(2)
Set r(1) = .Range(.Cells(1, Cp), .Cells(65536, Cp).End(xlUp))
dt = .Range(Dp).Value
End With
'
If r(1).Count = 1 Then
MsgBox "範囲を確認" + vbCrLf + r(1).Address(False, False), vbExclamation
Else
Select Case dt
Case 16 To 31
'念のため入力範囲クリア＆フォント黒
With r(1).Offset(Rp - 1, 1).Resize(r(1).Rows.Count - Rp + 1, Cmax)
.ClearContents
.Font.ColorIndex = 1
End With
'ループの最下段判定（部署がAのため）
Rmax = ws(1).Range("A65536").End(xlUp).Row
For RR = 4 To Rmax '4行目から処理
'部署判定
Set r(2) = ws(1).Cells(RR, 1)
With Application.WorksheetFunction
'ワークシート関数のCountIfで一致部署の有無を判定（無かったらMatchがエラーになるので）
If .CountIf(r(1), r(2).Value) = 0 Then
'どの部署とも一致しなかった人
msg = msg & vbCrLf & RR & "行目：" & r(2).Offset(0, 2).Value & " さん"
Else
'ワークシート関数のMatchで行番号を取得
Rpos = .Match(r(2).Value, r(1), 0)
With ws(2).Cells(Rpos, Cmax + r(1).Cells(1).Column)
'転記先の右端のセルに既にデータが入っていたらオーバーと表示
If .Value <> "" Then
msg = msg & vbCrLf & RR & "行目：" & r(2).Offset(0, 2).Value & " さん（人数オーバー）"
Else
With .End(xlToLeft).Offset(0, 1)
.Value = r(2).Offset(0, 2).Value
'フォントの色をここで分岐
With .Font
Select Case r(2).Offset(0, dt - 16 + 3).Value
Case "休": .ColorIndex = 3
Case "外": .ColorIndex = 5
End Select
End With
End With
End If
End With
End If
End With
Next
'
If msg <> "" Then MsgBox "部署エラー" & msg, vbExclamation, "転記できませんでした"
Case Else
MsgBox "日付指定エラー", vbExclamation, "中断"
End Select
End If
'
Erase ws, r
End Sub
こんな感じです。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 07/3/31(土) 9:05 -
