Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : Excel 2010)
日程計画表作成におけるFindの検索方向について
投稿日時: 18/05/18 19:46:37
投稿者: 河童TKO

いつも大変お世話になっております。
 
計画表の作成において質問があります。
各担当者ごとの計画表を作成しています。
理想は、横向きのガンチャートみたいにしたいです。
 
B列に担当者
C列に計画日数
D列E列から1ヶ月分の日付
 
縦軸の担当者と計画日数は、随時増えてきます。
横軸に日付(1日を午前と午後に分けています)を配置しています。
 
 
縦軸の担当者は
 
                     5/1 5/2 5/3
       登録日数 午前 午後 午前 午後 午前 午後
1青木 2    ○ ○  ○  ○
2井川
3宇野
4青木 1               ○ ○
5井川
6宇野
みたいに増えていきます。
 
縦軸の上から順に日程計画表を埋めていきます。
1青木の計画はまだ入力されていない状態なので
登録日数が「2」の場合、計画をどこから開始するのかを
手入力で選択させます。
5/1の午前が選択されたら5/2の午後まで「○」を入力させます。
 
次に4青木の計画で登録日数「1」を入力するときは、
上の計画を検索して入力されている最終日の次から開始させたいです。
 
 
計画の開始日は、
上側に入力された計画がない場合は、
開始日を手入力
上側に入力された計画がある場合は、
最終日を取得して翌日から開始日を設定することと
上側に入力された計画はあるが、計画が入力されていない場合は
開始日を手入力
 
困っていることは、
1青木の上側に入力されている計画がないか検索する時
Findを使用している(上方向検索)のですが、
4青木が検索に引っかかってしまいます。
 
 
 
上側に同じ担当がない、入力された計画がない場合は手入力で開始日を設定
それ以外は最終日の次のセルから開始日を自動で設定したいです。
 
また、一日を0.5日単位でカウントしたいとき
登録日数 Mod 0.5
にすると「0で除算しました。」というエラーが発生します。
登録日数は、整数または0.5単位の少数にしたいです。
どのように日数の入力チェックをかければよいですか?
0.5単位の数値かどうか判定したいです。
 
 
Private Sub CommandButton1_Click()
 
    Dim actCol As Long
    Dim actRng As Range
    Dim w登録日数 As Variant
    Dim w担当者 As Variant
     
    'アクティブな列
    actCol = ActiveCell.Column
     
    w登録日数 = ActiveCell.Cells.Value
    
  '登録日数の入力チェック
    If w登録日数 <> "" Then
 
        If IsNumeric(w登録日数) = True Then
      'ここでエラーが発生(0.5単位の数値化判定したい)
            If w登録日数 Mod 0.5 = 0 Then
 
                '登録日数セット(0.5日単位)
                w登録日数 = w登録日数 / 0.5
            Else
                MsgBox "登録日数に誤りがあります。"
                Exit Sub
 
            End If
 
        Else
 
            MsgBox "登録日数に誤りがあります。"
            Exit Sub
 
        End If
 
    Else
 
        MsgBox "登録日数に誤りがあります。"
        Exit Sub
 
    End If
             
               
    'A列だと左隣の値を取得できないため
    If actCol <> 1 Then
     
        '左隣の値を取得(担当者担当者)
        Set actRng = ActiveCell.Offset(0, -1)
        actRng.Select
     
        w担当者 = actRng.Value
 
        actCol = ActiveCell.Column
 
        If actCol = 2 Then
            Dim actRng2 As Range
            '上方向で検索
            '上方向のみ検索させたい
            Set actRng2 = Range("B:B").Find( _
                  What:=w担当者, _
                  SearchDirection:=xlPrevious, _
                  After:=ActiveCell)
                 
                 
                '上方向になかった場合
                If actRng2 Is Nothing Then
                    MsgBox "見つかりませんでした。"
                 
                    Dim sakiCELL As Range
                    Set sakiCELL = Application.InputBox(Prompt:="複写先セルを選択してください。", Type:=8)
                 
                    Dim r
                    Dim c
                     
                    '開始位置(RangeからCellに変換)
                    r = sakiCELL.Row
                    c = sakiCELL.Column
                     
                    For i = 1 To w登録日数
                     
                        '登録日数分繰り返す
                        Cells(r, c) = "○"
                         
                        c = c + 1
                    Next i
                 
                     
                Else
                '上方向あった場合場合
                    '最終日の翌日を開始日にしたい
                     
                     
                    MsgBox actRng2.Address(False, False)
                End If
                 
        End If
 
 
    End If
     
End Sub

回答
投稿日時: 18/05/18 21:50:41
投稿者: mattuwan44

1)すでに入力があるかはCount関数で数えてみればよいと思います。
2)0.5で割らなくても、2を掛ければ同じ結果になると思います。
3)ボタン押すより、数字入力でマクロ起動の方が操作者の手間が少なくなると思います。
4)最初の位置の指定はダブルクリックで書いてみました。
5)動作確認はしてません。上手く動かなかったらごめんなさいです。
コードを読み解いて意図を汲み取っていただけるとありがたいです。
 
Option Explicit
Dim mrngTable As Range
Dim mrngBody As Range
Dim mrngSide As Range
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.CountLarge > 1 Then Exit Sub
    If mrngTable Is Nothing Then GetTable
    If WorksheetFunction.Count(mrngSide) <> 1 Then Exit Sub
    Target.Resize(, Me.Cells(Target.Row, "B").Value * 2).Value = "○"
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range
    Dim ixCol As Long
 
    If Target.Column = 1 Then GetTable
    If mrngTable Is Nothing Then GetTable
    If Intersect(mrngSide, Target) Is Nothing Then Exit Sub
    If WorksheetFunction.Count(mrngSide) < 2 Then Exit Sub
 
    For Each c In mrngBody.SpecialCells(xlCellTypeConstants)
        If c.Column > ixCol Then ixCol = c.Column
    Next
 
    Me.Cells(Target.Row, ixCol + 1).Resize(, Target.Value * 2).Value = "○"
End Sub
 
Private Function GetTable() As Range
    Set mrngTable = Me.Range("A1").CurrentRegion
    Set mrngBody = Intersect(mrngTable, mrngTable.Offset(2, 2))
    Set mrngSide = mrngBody.Columns(0)
End Function

投稿日時: 18/05/19 17:01:03
投稿者: 河童TKO

こんばんは。
 
mattuwan44さん、お返事ありがとうございました。
自分にはコードの難易度が高くてあまり理解できませんでした。
せっかくアドバイス頂いたのに、申し訳ございません。
0.5日単位を参考にできました。
 
担当者を上方向に検索して、
対象があれば、縦方向に値があるか検索するようにしました。
担当者用のFor分の中に値の検索ようのFor分を設定してみました。
 
追加の仕様として
計画表のセルに「〇」の入力とセルの塗りつぶしを同時にするようにしました。
担当者のセルの背景色を取得して、同じ色を計画表に設定します。
 
今困っていることは、
1.「〇」の文字列
セルに入力された「〇」とコード上に設定している「〇」が
IF文の条件として判定できないことです。
同じ文字列だとおもうのですが、「〇」は使用できないのでしょうか?
一時的に「a」を代用しています。
 
2.土日をカウントに含めない条件
追加条件になりますが、土日をカウントに含めないようにしたいです。
For分のカウンタを土日の場合は戻したいです。
土日のセルの背景色はきまっているので、
セルが土日かどうかは判定できます。
登録日数分で繰り返しているので、どのように土日を
除外すればよいですか?
 
アドバイス、よろしくお願いします。
 
'色塗り処理
' 1.最終日を取得できた場合、最終日の次セルを開始日とする
' 2.最終日を取得できなかった場合、インプットボックスで開始日を入力する
' 3.土日はカウントしない
Public Sub PlanColoring_Kenshu()
 
Dim actCol As Long
Dim actRow As Long
Dim actRng As Range
Dim w登録日数 As Variant
Dim w担当者 As Variant
Dim w担当者_背景色 As Long
Dim cntRow As Long
Dim cntCol As Long
Dim chkInputData As Boolean
Dim chkData As Variant
Dim chkColor As Long
 
    'アクティブな列
    actCol = ActiveCell.Column
    actRow = ActiveCell.Row
     
    If actCol <> COL_KENSHU Then
        MsgBox "検収の登録日数を指定してください。"
        Exit Sub
    End If
    If actRow < ROW_ITEMLINE Then
        MsgBox "選択範囲に誤りがあります。"
        Exit Sub
    End If
         
    w登録日数 = ActiveCell.Cells.Value
 
    '登録日数の入力チェック(0.5日単位)
    If w登録日数 <> "" Then
        If IsNumeric(w登録日数) = True Then
            If w登録日数 > 0 Then
                Dim w日数判定
                w日数判定 = CDbl(w登録日数 * 2)
                w日数判定 = w日数判定 - Int(w日数判定)
                w日数判定 = Abs(w日数判定) '絶対値の取得
                If w日数判定 <> 0 Then
                    MsgBox ("0.5日単位で入力してください。")
                    Exit Sub
                End If
                w登録日数 = w登録日数 / 0.5
            Else
                MsgBox "登録日数に誤りがあります。"
                Exit Sub
            End If
        Else
            MsgBox "登録日数に誤りがあります。"
            Exit Sub
        End If
    Else
        MsgBox "登録日数に誤りがあります。"
        Exit Sub
    End If
     
     
    '担当者(登録日数の左隣の値を取得)
    Set actRng = ActiveCell.Offset(0, -1)
    actRng.Select
    w担当者 = actRng.Value '担当者名
    w担当者_背景色 = actRng.Interior.Color '担当者セルの背景色
    actCol = ActiveCell.Column '担当者セルの列
    actRow = ActiveCell.Row '担当者セルの行
     
    chkInputData = False
    '上方向に同じ担当者のデータの有無を判定(明細開始行まで)
    '同じ担当者のセルは必ず同じ背景色にすること
    For cntRow = actRow - 1 To ROW_ITEMLINE Step -1
         
        If chkInputData = True Then Exit For
         
        If w担当者 = Cells(cntRow, actCol).Value Then
                 
                '塗りつぶしたセルがあるか判定(最終の入力値を取得)
                For cntCol = PLAN_MAX_COL To PLAN_STR_COL Step -1
                 
' chkData = Cells(cntRow, cntCol).Value
' If chkData = "a" Then
'' If chkData = "〇" Then '条件に引っかからない
'
'' MsgBox Cells(cntRow, cntCol).Address
' chkInputData = True
' Exit For
' End If
                     
                    chkColor = Cells(cntRow, cntCol).Interior.Color
                    If w担当者_背景色 = chkColor Then
                        MsgBox Cells(cntRow, cntCol).Address
                       chkInputData = True
                       Exit For
                    End If
                 
                Next cntCol
              
        End If
             
    Next cntRow
     
    '色塗りの処理
    If chkInputData = True Then
     
        Dim j As Long
         
        For j = 1 To w登録日数
             
            Cells(actRow, cntCol + 1) = "a"
            Cells(actRow, cntCol + 1).Interior.Color = w担当者_背景色
            cntCol = cntCol + 1
             
        Next j
         
 
    Else
         
        On Error Resume Next
        Dim sakiCELL As Range ' 開始セル
        Dim ans ' InputBoxの戻り
        Dim flg As Boolean ' 数値かどうかの判定フラグ
         
        Set sakiCELL = Application.InputBox(Prompt:="複写先セルを選択してください。", Type:=8)
         
        'キャンセルのエラートラップ
        If Err.Number > 0 Then
            MsgBox "処理がキャンセルされました。", vbExclamation
            Exit Sub
        End If
         
        Dim r, c
        Dim i As Long
        '開始位置(RangeからCellに変換)
        r = sakiCELL.Row
        c = sakiCELL.Column
 
        For i = 1 To w登録日数
 
            '登録日数分繰り返す
            Cells(r, c) = "a"
            Cells(r, c).Interior.Color = w担当者_背景色
            c = c + 1
             
        Next i
     
    End If
     
End Sub
 
 

回答
投稿日時: 18/05/19 17:26:33
投稿者: mattuwan44

>同じ文字列だとおもうのですが、「〇」は使用できないのでしょうか?
○ 丸印
〇 漢数字
よく見ると微妙に違いますが、
ぱっと見区別がつきません。
 
そういう時は文字コードを調べてみたらいいかと思います。
 
http://www.relief.jp/docs/excel-check-character-code.html
http://excelwork.info/excel/funcasc/
 
 
>追加条件になりますが、土日をカウントに含めないようにしたいです。
カレンダーには欄を作るけど操作対象に含めないってことですか?
それとも丸は書くけど数は数えないって意味ですか?
 
ごめんけど、変数の登場数がそんなに必要なのかなぁってくらい多いし、
コードもなんか長いので、ちょっと解読する気になれないので、
他の方の回答をお待ちください。
 
僕なら、たぶん別の表を用意して、
 

┌──┬──────┬────┐
│氏名│前の人の氏名│所要日数│
├──┼──────┼────┤
│あ  │う          │       3│
├──┼──────┼────┤
│い  │-           │     2.5│
├──┼──────┼────┤
│う  │い          │     1.5│
└──┴──────┴────┘

それを、別表にマクロで書くようにするかなぁ。。。
 
まぁ、他人それぞれ考えがあるし、どれがベストってわけでもないので、参考まで。

回答
投稿日時: 18/05/19 17:36:56
投稿者: mattuwan44

一応、僕のコードの構想を説明しておくと、
ジャンプ機能で、何か入っているセルを取得し、
その各セルの列番号を見て行って、最大値を探せば、
次入力するセルの列が解るだろうというアプローチをしています。
 
参考URL>>
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_cell.html#specialcells
 
あとはいかにして、思い通りのセル範囲を取得するかですかね。。。
セルを選択させるコードをわざと入れて、ステップ実行をして、
セル範囲を可視化しながら試すとなにか解るかも。
(あ、上手く動かない可能性もありましたね^^;)

投稿日時: 18/05/19 19:43:50
投稿者: 河童TKO

mattuwan44さん、ありがごうございます。
 
「〇」の文字コードが異なっていました。
勉強になりました。
 
そうなんですよね。
すごく読みにくくなってしまいます。
 
土日を含めずにカウントする処理については、
土日には「〇」入力しないということです。
 
例えば、
開始日が金曜日で登録日数が3日のとき
5/18(金) 〇
5/19(土)
5/20(日)
5/21(月) 〇
5/22(火) 〇
としたいです。
 
For文のIf文を追加すると永久ループになります。
土日のセルの背景色は他の曜日と違います。
背景色を条件として判定しています。
土日の場合は処理をとばすが、
そのとばした日数は元に戻したいです。
 
Dim j As Long
For j = 1 To w登録日数
  '土日の場合は「〇」と背景色の設定はしない
  If WEEKENDS_COLOR <> Cells(actRow, cntCol + 1).Interior.Color Then
      Cells(actRow, cntCol + 1) = "〇"
    Cells(actRow, cntCol + 1).Interior.Color = w担当者_背景色
    cntCol = cntCol + 1
             
  Else
        j = j - 1
  End If
Next j
 
 
 

回答
投稿日時: 18/05/19 23:10:05
投稿者: simple

ループの書き方ですが、
この場合は、Do ... Loopを使ったほうが自然かもしれません。
・○をつける都度、カウンタ変数を加算していき、
・それが登録日数に達したら、ループから抜ける、
という考えかたでどうですか?

回答
投稿日時: 18/05/20 10:46:51
投稿者: simple

  A列    B       C       D       E       F
1                5月1日          5月2日  
2       登録日数 午前    午後    午前    午後
3 青木   2       ○      ○      ○      ○ 
4 井川   1                               
5 宇野                                   
6 青木   1                               
7 井川   1.5                             
8 宇野                                   
6 青木   1.5                             

というシートレイアウトだとして、
コードを書いてみました。
 
手法的には、
・書式付きの検索を使ったこと
・ワークシート関数を使って土日判定をしたこと
・プロシージャを分割して見やすく(自称)したこと
くらいです。
 
十分に検証していませんが、参考にしてください。
 
Option Explicit

Const COL_KENSHU As Long = 2
Const ROW_ITEMLINE As Long = 3

Dim w登録日数 As Variant

'色塗り処理
' 1.最終日を取得できた場合、最終日の次セルを開始日とする
' 2.最終日を取得できなかった場合、インプットボックスで開始日を入力する
' 3.土日はカウントしない

Public Sub PlanColoring_Kenshu()
    Dim 担当者セル      As Range
    Dim w担当者         As Variant
    Dim w担当者_背景色  As Long
    Dim r               As Range
    Dim sakiCELL        As Range  '担当開始セル

    '(1)入力のチェック ----------------------------------------------
    If 入力チェック Then Exit Sub

    w登録日数 = ActiveCell.Value

    '(2)登録日数の入力チェック(処理後のw登録日数は0.5日単位であることに注意)
    If 登録日数チェック Then Exit Sub

    '(3)担当者(登録日数の左隣の値)を取得-----------------------------
    Set 担当者セル = ActiveCell.Offset(0, -1)
    w担当者 = 担当者セル.Value                  '担当者名
    w担当者_背景色 = 担当者セル.Interior.Color  '担当者セルの背景色

    '(4)直前の担当日があるかをチェック -------------------------------
    Set r = 直前担当日(担当者セル)

    '(4)登録処理(○書込、色塗り)-------------------------------------
    If r.Row < 担当者セル.Row Then  '既存の担当日がある場合

        Call 登録処理(担当者セル, r.Column + 1, w登録日数, w担当者_背景色)

    Else                            '既存の担当日がない場合
        On Error Resume Next
        Set sakiCELL = Application.InputBox( _
                       Prompt:="複写先セルを選択してください。", Type:=8)

        If Err.Number > 0 Then
            MsgBox "処理がキャンセルされました。", vbExclamation
            Exit Sub
        End If
        On Error GoTo 0

        Call 登録処理(担当者セル, sakiCELL.Column, w登録日数, w担当者_背景色)
    End If
End Sub

Function 入力チェック() As Boolean  '不備があればTrueを返す
    Dim actCol As Long
    Dim actRow As Long

    'アクティブな列
    actCol = ActiveCell.Column
    actRow = ActiveCell.Row

    If actCol <> COL_KENSHU Then
        MsgBox "検収の登録日数を指定してください。"
        入力チェック = True
        Exit Function
    End If
    If actRow < ROW_ITEMLINE Then
        MsgBox "選択範囲に誤りがあります。"
        入力チェック = True
        Exit Function
    End If
End Function

Function 登録日数チェック() As Boolean
    'ロジックは変えていません。
    If w登録日数 <> "" Then
        If IsNumeric(w登録日数) = True Then
            If w登録日数 > 0 Then
                Dim w日数判定
                w日数判定 = CDbl(w登録日数 * 2)
                w日数判定 = w日数判定 - Int(w日数判定)
                w日数判定 = Abs(w日数判定)    '絶対値の取得
                If w日数判定 <> 0 Then
                    MsgBox ("0.5日単位で入力してください。")
                    Exit Function
                End If
                w登録日数 = w登録日数 * 2
            Else
                MsgBox "登録日数に誤りがあります。"
                登録日数チェック = True
                Exit Function
            End If
        Else
            MsgBox "登録日数に誤りがあります。"
            登録日数チェック = True
            Exit Function
        End If
    Else
        MsgBox "登録日数に誤りがあります。"
        登録日数チェック = True
        Exit Function
    End If
End Function

'書式付き検索を使用して直前の担当日を取得
Function 直前担当日(r As Range) As Range
    Application.FindFormat.Interior.Color = r.Interior.Color
    Set 直前担当日 = Cells.Find(What:="*", After:=r, LookIn:=xlFormulas, _
                           LookAt:=xlPart, SearchOrder:=xlByRows, _
                           SearchDirection:=xlPrevious, _
                           MatchCase:=False, MatchByte:=False, _
                           SearchFormat:=True)
End Function

'「担当者セル」の行の、「列」以降に、「w登録日数」箇所の土日以外に色を付ける
Function 登録処理(担当者セル As Range, 列 As Long, _
                  w登録日数 As Variant, w担当者_背景色 As Long)
    Dim myCount As Long
    Dim r As Range
    Dim y As Long

    Set r = Cells(担当者セル.Row, 列)
    Do
        '曜日を取得(土日は6,7となる)
        If Cells(1, r.Column).Value = 0 Then
            y = WorksheetFunction.Weekday(Cells(1, r.Column - 1).Value, 2)
        Else
            y = WorksheetFunction.Weekday(Cells(1, r.Column).Value, 2)
        End If

        If y <= 5 Then
            r.Value = "○"
            r.Interior.Color = w担当者_背景色
            myCount = myCount + 1
        End If
        
        If myCount >= w登録日数 Then Exit Function
        Set r = r.Offset(0, 1)
    Loop
End Function

投稿日時: 18/05/21 00:28:55
投稿者: 河童TKO

こんばんは。
simpleさん、お返事ありがとうごさいました。
 
希望する結果に一応なりました。
 
ありがとうございました。
 
参考にした繰り返し処理は、Do until Loop を使いました。
登録日数と土日を除いた塗りつぶした回数までの条件です。
 
また、サンプルコードも今後参考にさせていただきます。
 
        cntColor = 0
        Do Until w登録日数 = cntColor
            '曜日を取得(土日の背景色)
            If WEEKENDS_COLOR <> Cells(actRow, cntCol + 1).Interior.Color Then
                '土日以外はセルを塗りつぶす
                Cells(actRow, cntCol + 1) = "a"
                Cells(actRow, cntCol + 1).Interior.Color = w担当者_背景色
                cntColor = cntColor + 1
            End If
            cntCol = cntCol + 1
        Loop