Excel VBA質問箱 IV

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

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


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

33921 / 76734

←次へ　｜　前へ→


	【48028】Re:確当値を色別で転記

りん

- 07/3/31(土) 9:05 -


	引用なし

	パスワード

hiro さん、おはようございます。

>休日一覧表1ヶ月分から日にちを指定して一日分の出勤状況を部署ごとに表示したいのですが？
>シート1のA4から部署コード１から10　B4から社員コード1から100　C4から氏名
>D2からAH2まで日にち16から31が入力してあります
>　 A　　　B　　　C　　　D E　F　G
>1
>2　　　　　　　　　　 16　17　 18
>3 部署　社員　氏名　月　　火　水
>4 　1　　　1　　a　　休　　　外
>5 　1　　　2　　b　　外　休
>6　 2　　　3　　c　　　　　外　休
>7　 4　　　4　　d
>8　 3　　　5　　e　　休
>9　 4　　　6　　f　　　　　休　休
>10　　　　　　　　　　　　　　　
>
>シート2のK1に日にちを入力して
>その日の勤怠状況を部署別にブランクの人は黒
>　　　　　　　　　　　　　休の人は赤
>　　　　　　　　　　　　　外の人は青で表示したいのです

たとえばこんな方法。
Sub test()
　 Dim ws(1 To 2) As Worksheet, msg As String
　 Dim Rmax As Long, RR As Long, r(1 To 3) As Range, Rpos As Variant, dt As Integer
　 '
　 With ThisWorkbook.Worksheets
　　　Set ws(1) = Worksheets("Sheet1") '元
　　　Set ws(2) = Worksheets("Sheet2") '先
　 End With
　 '一覧表の範囲設定
　 With ws(2)
　　　Set r(1) = .Range(.Range("A1"), .Range("A65536").End(xlUp))
　　　dt = .Range("K1").Value
　 End With
　 '
　 Select Case dt
　　　Case 16 To 31
　　　　 '念のため入力範囲クリア＆フォント黒
　　　　 With r(1).Offset(1, 1).Resize(r(1).Rows.Count - 1, 10)
　　　　　　.ClearContents
　　　　　　.Font.ColorIndex = 1
　　　　 End With
　　　　 '最下段判定
　　　　 Rmax = ws(1).Range("A65536").End(xlUp).Row
　　　　 For RR = 4 To Rmax
　　　　　　'部署判定
　　　　　　Set r(2) = ws(1).Cells(RR, 1)
　　　　　　With Application.WorksheetFunction
　　　　　　　 If .CountIf(r(1), r(2).Value) = 0 Then
　　　　　　　　　msg = msg & vbCrLf & RR & "行目：" & r(2).Offset(0, 2).Value & " さん"
　　　　　　　 Else
　　　　　　　　　Rpos = .Match(r(2).Value, r(1), 0)
　　　　　　　　　With ws(2).Cells(Rpos, "K")
　　　　　　　　　　 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
　 '
　 Erase ws, r
End Sub

3 hits

▼

【48021】確当値を色別で転記 hiro 07/3/30(金) 20:30