Excel VBA質問箱 IV

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

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


5948 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

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

引用なし
パスワード
   いつも教えて頂きありがとうございます

休日一覧表1ヶ月分から日にちを指定して一日分の出勤状況を部署ごとに表示したいのですが?
シート1のA4から部署コード1から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に日にちを入力して
その日の勤怠状況を部署別にブランクの人は黒
             休の人は赤
             外の人は青で表示したいのです
シート2
 A   B   C  D    
1 部署 氏名        a eを赤 
2 1  a   b       b を青
3 2  c          cdfを黒で表示
4 3  e
5 4  d   f

k1に16を入力すると上のように転記させやいのですが
現状"休"の人を表示するところまでしかわからず悩んでおります
どなたかよろしくお願いいたします(部署別にもなっていません)
シート1の部署コードは順番に並んでいません 社員No.は1から並んでいます
各部署1人から最高10人までです

Public Sub Test()

  Dim wsIn As Worksheet
  Dim wsOut As Worksheet
  Dim rngFind As Range
  Dim sFind As String
  
  Dim celFound As Range
  Dim cFound As Long
  
  Dim ixDate As Long
  
  Dim firstAddress As String
  
  Set wsIn = ThisWorkbook.Worksheets("Sheet1")
  Set wsOut = ThisWorkbook.Worksheets("Sheet2")

  ixDate = wsOut.Range("K1").Value
  With wsIn
  If ixDate >= 16 Then
    Set rngFind = .Range(.Cells(4, 3 + ixDate - 15), .Cells(30, 3 + ixDate - 15))
   Else
    Set rngFind = .Range(.Cells(4, 3 + ixDate + 16), .Cells(30, 3 + ixDate + 16))
   End If
  End With

  sFind = "H"
  
  
  Set celFound = rngFind.Find(sFind, _
                , _
                xlValues, _
                xlWhole, _
                xlByRows, _
                xlNext, _
                True, _
                True)
                
  If Not (celFound Is Nothing) Then
    firstAddress = celFound.Address
    Do
      cFound = cFound + 1
      With wsOut.Range("B2").Offset(((cFound - 1) \ 10), ((cFound - 1) Mod 10))
   .Value = wsIn.Cells(celFound.Row, "C").Value
   .Font.ColorIndex = 3
End With

      
      Set celFound = rngFind.FindNext(celFound)
      If celFound Is Nothing Then Exit Do
      If celFound.Address = firstAddress Then Exit Do
    Loop
  End If


 End Sub

【48028】Re:確当値を色別で転記
回答  りん E-MAIL  - 07/3/31(土) 9:05 -

引用なし
パスワード
   hiro さん、おはようございます。

>休日一覧表1ヶ月分から日にちを指定して一日分の出勤状況を部署ごとに表示したいのですが?
>シート1のA4から部署コード1から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

【48034】Re:確当値を色別で転記
お礼  hiro  - 07/3/31(土) 23:06 -

引用なし
パスワード
   ▼りん さん:
朝早くからご教授頂きありがとうございます
早速試してみると見事に希望通り動きました ほんとにありがとうございます
それにしても すごいですね 私は初心者でfindでずっと悩んでいたので、りんさんのコードみてただただ感心するばかりです 私は素人で教えて頂いたコードを
100%理解でないのが現状です 立派なコードと言うかサンプル頂いて感謝いたします

もう少し質問させて頂きたいのですが レイアウトを変更したく思いましてシート2のB2から部署名を入れて出力データをC列から表示したいのですが修正箇所を教えていただけないでしょうか?それと一部署の人数が10人以上になったときの修正箇所も教えて頂けないでしょうか?
初歩的質問ばかりですいません よろしくお願いいたします
お礼が遅くなったことをお詫びします

【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
こんな感じです。

【48054】Re:確当値を色別で転記
お礼  hiro  - 07/4/1(日) 22:11 -

引用なし
パスワード
   りんさん 
またまたご親切なご教授ありがとうございます とても使いやすくして頂きひたすら感謝です コードにも説明付け加えて頂いて初心者の私には大助かりです
変数で色んなパターン試してレイアウト変更させてもらってます
素人にここまでして頂いてほんとにありがとうございました

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