Excel VBA質問箱 IV

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

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


33910 / 76734 ←次へ | 前へ→

【48040】Re:確当値を色別で転記
回答  りん E-MAIL  - 07/4/1(日) 10:20 -

引用なし
パスワード
   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
こんな感じです。

3 hits

【48021】確当値を色別で転記 hiro 07/3/30(金) 20:30 質問
【48028】Re:確当値を色別で転記 りん 07/3/31(土) 9:05 回答
【48034】Re:確当値を色別で転記 hiro 07/3/31(土) 23:06 お礼
【48040】Re:確当値を色別で転記 りん 07/4/1(日) 10:20 回答
【48054】Re:確当値を色別で転記 hiro 07/4/1(日) 22:11 お礼

33910 / 76734 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free