[[20130517154919]]　『値が入っているとその下のセルへ代入される方法』（ナッツ）　ページの最後に飛ぶ

『値が入っているとその下のセルへ代入される方法』（ナッツ）@2010

下記ような予定表を作成したいのですが、何かいい方法はないでしょうか。
困っている点としては、既に値が入っている場合は自動でその下のセルへ入力されて欲しい点です。
その他でも何か方法があれば教えて頂けませんでしょうか。

縦７、横７のマスを印刷して手書きで予定表としています。
これを手書きでなくデータで対応したいです。

Ａ列は縦に月～日の日付を書く欄です。
Ｂ～Ｇ列は各班の巡回現場を書く欄にしています。
（うまく位置が合わせられずわかりずらくて申し訳ございません）

Ａ列　　　　Ｂ　　　Ｃ　・・・・・・Ｇ列　
　　　　　　Ａ班　　Ｂ班　　　　　　Ｆ班

1/1月　　　ヤマダ　ケーズ　　　　　ビッグ
　　　　　　ケーズ　　　　　　　　　ヨドバシ

1/2火　　　ニトリ　ファミマ　　　　西武
　　　　　　東急
　　　　　　三越
　　　　　　大丸
・
・
・
1/6土　　　マック
1/7日

といった形です。

別のエクセルに予定データがあり、そこには各現場、予定日、班の入力があります。
それを上記のようなレイアウトにする事はできないでしょうか？

希望は、別の予定データに現場名、日付、班を入力すれば、上記のような形になってほしいです。

別データの形式は
Ａ列　Ｂ列Ｃ列
日付　現場名　班　　
1/1　ヤマダ　Ａ
1/1　ケーズ　Ｂ
1/1 ケーズ　Ａ
・
・
・
1/2 西武　　Ｇ
・
・

となってます。

1日、1班、1現場であれば数式でできるのですが、最大で日、1班、7現場くらいの事があります。現場数は日・班により異なります。

その為、予定表各日付の行を7行で1班マスにする事にし、上記の図だと、1/1A班のヤマダはB2、1/2A班ニトリはB8、1/6A班マックはB32といった７行1班でイメージしたのですが、セルに数式を入れるくらいの知識しか無く、全然わかりません。

例えば、1/1のＡ班の1行目（B3）に既に値が入っている為、Ａ班の2現場目は2行目（B4）に入力されるようにならないでしょうか。

 こんな塩梅でしょうか？(ROUGE)
　
Sub Sample()
Dim tbl, x(), ary, ky
Dim i As Long, ii As Long, n As Long
Dim flg As Boolean
Dim ws As Worksheet
Const hanmei As String = "Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ"
ary = Split(hanmei)
Set ws = Sheets("Sheet2")
tbl = Sheets("Sheet1").Range("A1").CurrentRegion.Resize(, 3).Value
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(tbl, 1)
        If .Exists(tbl(i, 1)) Then
            x = .Item(tbl(i, 1))
            n = Application.Match(tbl(i, 3), ary, 0)
            flg = True
            For ii = 1 To UBound(x, 2)
                If x(n, ii) = "" Then
                    flg = False
                    x(n, ii) = tbl(i, 2)
                    Exit For
                End If
            Next
            If flg Then
                ReDim Preserve x(1 To 7, 1 To UBound(x, 2) + 1)
                x(n, UBound(x, 2)) = tbl(i, 2)
            End If
            .Item(tbl(i, 1)) = x
        Else
            ReDim x(1 To 7, 1 To 1)
            n = Application.Match(tbl(i, 3), ary, 0)
            x(n, 1) = tbl(i, 2)
            .Item(tbl(i, 1)) = x
        End If
    Next
    i = 2
    ws.Range("A1").CurrentRegion.Resize(, 7).Offset(1).ClearContents
    For Each ky In .Keys
        x = .Item(ky)
        ws.Cells(i, 1).Value = ky
        ws.Cells(i, 2).Resize(UBound(x, 2), 7).Value = Application.Transpose(x)
        i = i + UBound(x, 2)
    Next
End With
End Sub

ありがとうございます。

すみません。
VBAも初心者なので、書かれている事のほとんどが理解できていないのですが、
走らせてみると、予定データが消えて、反映もされないです。

sheet1がマスの予定表、sheet2が予定データ入力シートでよろしいんですよね？
sheet2のA1日付、B1現場名、C1班というフィールド項目にして、
2行目以降に各データを入力しているのですが、消えてしまいました。

すみません。

 > sheet1がマスの予定表、sheet2が予定データ入力シートでよろしいんですよね？
まったく逆で記述しております。。。orz
(ROUGE)

すみませんでした。

逆にしてやってみたんですが、
実行時エラー１３、「型が違います」となります。

デバックは、n = Application.Match(tbl(i, 3), ary, 0)に反応してます。

力不足は重々承知しております。

いかがなもんでしょうか。

 実際の班名と例示されたものが違うからでしょうね。
データシートの入力が「Ａ～Ｇ」となっていて、予定表が「Ａ班～Ｇ班」となっていれば可能なはずです。
もしかして、そこも自動化を希望されていますか？
(ROUGE)

ROUGE様

ありがとうございます。
入力、班名などは教えて頂いた通りなんですが、やはり同じエラーになってしまいます。
もう一度確認の為に記載致します。
私の知識不足とレイアウト記述不足が原因ですので、ご面倒でなければご確認頂ければ幸いです。

◆sheet1: 予定表シート

◆1行目　予定表の班名を入力している行・・・・B1=A班～H1=G班

◆A列　　日付行・・・現場数が7件まで対応できるように、7行を1日としています⇒日付列（A列）はセル結合をしています。念のため結合を外しても試しましたが同エラーでした。
　結合状態では、A2=1/1、A9=1/2、A16=1/3～A44=1/7となっています。

1週間の月～日でA4横1枚に出力できるようなレイアウトにしたいのでこのような形になっています。

◆B列～H列の2行目以下　　それぞれの日付、班に対応した現場名が入力されて欲しいです。
　B2なら1/1のA班の1件目、B9なら1/2のA班の1件目、H40なら1/6のG班の4件目といった形です。

◆sheet2 予定入力シート

◆1行目　A1＝日付　　B1=現場名　C1＝班　のフィールド名の行

◆2行目以降　　各予定の情報を入力
A2=1/1 B2=ヤマダ　C2=A
A3=1/2 B3=ニトリ　C3=A
A4=1/2 B4=西武　 C4=G 　

以上のような形です。
今は、試しで3件ほどしか入力はしていません。

何かお気づきの点などあればよろしくお願い致します。

 全角と半角の違いのような気がします。(ROUGE)

ありがとうございます。

半角で入れていたのですが、全角設計だったのでしょうか？
全角にもしてみましたが同様でした。

私自身のあまりにもの知識不足だと思いますので、お手数をおかけして申し訳ございませんでした。

本当にありがとうございました。（ナッツ）

 位置関係がいまいちですが、[入力予定]のようなデータを、[予定表]に転記するサンプルです。
 位置関係、シート名等を確認の上試してください。

   [入力予定]
      A    B        C 
   1  日付 現場名   班
   2  1/1  ヤマダ   A 
   3  1/1  ケーズ   A 
   4  1/1  ケーズ   B 
   5  1/1  ビッグ   C 
   6  1/1  ヨドバシ C 
   7  1/2  ニトリ   A 
   8  1/2  ファミマ B 
   9  1/2  西武     C 
   10 1/2  東急     A 
   11 1/2  三越     A 
   12 1/2  大丸     A

   [予定表]
      A    B      C        D        E   F   G   H  
   1  日付 A班    B班      C班      D班 E班 F班 G班
   2  1/1  ヤマダ ケーズ   ビッグ                  
   3       ケーズ          ヨドバシ                
   4                                               
   5                                               
   6                                               
   7                                               
   8                                               
   9  1/2  ニトリ ファミマ 西武                    
   10      東急                                    
   11      三越                                    
   12      大丸

 Sub Test()
   Dim i&, j&, n&, r&, c&, D As Date
   Dim Sh As Worksheet
      Set Sh = Sheets("予定表")
      With Sheets("予定入力")
         n = -5 '初期値
         For i = 2 To 12
            If .Cells(i, 1).Value <> D Then
               n = n + 7
               D = .Cells(i, 1).Value
               Sh.Cells(n, 1).Value = .Cells(i, 1).Value '日付
            End If
            Select Case .Cells(i, 3).Value '記入位置列番号
               Case "A": c = 2
               Case "B": c = 3
               Case "C": c = 4
               Case "D": c = 5
               Case "E": c = 6
               Case "F": c = 7
               Case "G": c = 8
            End Select
            r = Sh.Cells(.Rows.Count, c).End(xlUp).Row + 1 '記入位置行番号
            If r < n Then r = n
            Sh.Cells(r, c).Value = .Cells(i, 2).Value '現場名
         Next
      End With
 End Sub
 (暇人)

暇人様

ありがとうございました。

きちんと動きました。すごいですね。

ただ説明不足で申し訳ございません。
こちらとしては、予定表のフォーマットは日付列、班行の一週間分の7×8マスは固定して、A2に日付を入れて、それ以降一週間を1枚として、それに対応する予定を反映するようなが希望です。

頂いたマクロのtoを予定分増やすと、ひたすら予定が反映され縦長な物になってしまいました。

しかし、今回の物でもかなり効率良く把握できるようになったので非常に助かりました。
ありがとうございます。

マクロだと知識が無く管理が難しいので、自分なりに下記方法でできないか考えてみたのですが、
ご面倒でなければ一度ご確認頂けませんでしょうか。

↓

まず、予定表は7×8マスのままです。
各班の詳細も7行1日のままです。

予定入力シートD列に巡回順の情報を増やします（1~7)。

日付、班、巡回順Noの３つで、セル座標を特定し、該当セルに反映させるように、セルへ数式へ入力するような形はできないでしょうか？

例えば、
1/1のAの1番目の現場であれば、予定表B2へ
1/6のCの3番目の現場であれば、予定表D40へ

といった具合に、A列の日付、1行目の班名、これらのX軸、Y軸が交差する範囲かつ、その中の何番目かで、各セルにその式を入れる事で対応はできないかなと思ったのですが、どうでしょうか？

A列の値取得、A2～H2の値取得、その結果の内の班順が呼応する物を反映する。
何分初心者の発想ですので、不可能かもしれません。

何卒ご教示頂ければ幸いです（ナッツ）

 > 予定表は7×8マスのまま
 ここを読み飛ばしていました。
 暇人さんのレイアウトで確認済み。
 (ROUGE)
　
Sub Sample2()
Dim tbl, x(), ary, ky
Dim i As Long, ii As Long, n As Long
Dim ws As Worksheet
Const hanmei As String = "A B C D E F G H"
ary = Split(hanmei)
Set ws = Sheets("Sheet1")
tbl = Sheets("Sheet2").Range("A1").CurrentRegion.Resize(, 3).Value
With CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(tbl, 1)
        If .Exists(tbl(i, 1)) Then
            x = .Item(tbl(i, 1))
            n = Application.Match(tbl(i, 3), ary, 0)
            For ii = 1 To 7
                If x(ii, n) = "" Then
                    x(ii, n) = tbl(i, 2)
                    Exit For
                End If
            Next
            .Item(tbl(i, 1)) = x
        Else
            ReDim x(1 To 7, 1 To 8)
            n = Application.Match(tbl(i, 3), ary, 0)
            x(1, n) = tbl(i, 2)
            .Item(tbl(i, 1)) = x
        End If
    Next
    i = 2
    ws.Range("A1").CurrentRegion.Resize(, 7).Offset(1).ClearContents
    For Each ky In .Keys
        x = .Item(ky)
        ws.Cells(i, 1).Value = ky
        ws.Cells(i, 2).Resize(7, 8).Value = x
        i = i + 7
    Next
End With
End Sub

 改訂版です。
  [予定入力]の、任意の行を選択して実行すると、その行からの、1週間分が転記されます。
 まずは動きを確認してから、次の構想を考えてください。
 Sub TestB() 
   Dim i&, j&, n&, r&, c&, Str&, D As Date
      Sheets("予定表").Range("a2:h50").ClearContents
      With Sheets("予定入力")
         Str = ActiveCell.Row '処理の開始行
         n = -5 '初期値
         For i = Str To .Cells(.Rows.Count, "a").End(xlUp).Row '最終行まで
            If .Cells(i, 1).Value <> D Then
               n = n + 7
               If n > 44 Then Exit Sub '1週間分で終了
               D = .Cells(i, 1).Value
               Sheets("予定表").Cells(n, 1).Value = .Cells(i, 1).Value '日付
            End If
            Select Case .Cells(i, 3).Value
               Case "A": c = 2
               Case "B": c = 3
               Case "C": c = 4
               Case "D": c = 5
               Case "E": c = 6
               Case "F": c = 7
               Case "G": c = 8
            End Select
            r = Sheets("予定表").Cells(.Rows.Count, c).End(xlUp).Row + 1 '記入位置行番号
            If r < n Then r = n
            Sheets("予定表").Cells(r, c).Value = .Cells(i, 2).Value '現場名
         Next
      End With
 End Sub
 (暇人)

暇人様

ありがとうございます。

7マスで止まりました。

申し訳ございません。
土日は現場があるときと無いときがあり、動かしてみたところ、こちらでは班稼働が1班も無い日は、飛ばして次の班稼働がある日になってるように思います。

班稼働が無い日もとりあえず日付と空白マスだけ表示されるようにはできるのでしょうか？

イメージとしては、A2に日付を入れると一週間日付曜日が入力され（A2+1をオートフィル）、
その日付に対応する予定が各マスに反映されるようにすることは可能でしょうか？

というかVBA知識が無さ過ぎて、質問というより単なる作成依頼になってしまっていて申し訳ございません。

（ナッツ）

 細かなテストはしていません。
 [予定表]の、2行目以下一旦 Clear して、[A2] へ、開始日(曜日なしの普通の日付データ)を入力して、実行。

 Sub 予定C() 
   Dim i&, j&, n&, r&, c&, Str&, D As Date
   Dim Tar&, m
      With Sheets("予定表")
         .Cells.Font.Color = xlGeneral
         D = .Cells(2, 1).Value
         For i = 2 To 44 Step 7
            .Cells(i, 1).Value = D
            If Weekday(D) = 1 Then .Cells(i, 1).Font.Color = vbRed '土日着色
            If Weekday(D) = 7 Then .Cells(i, 1).Font.Color = vbBlue
            m = Application.Match(CLng(D), Sheets("予定入力").Columns(1), 0)
            If Not IsError(m) Then
               Do
                  Select Case Sheets("予定入力").Cells(m, 3).Value
                     Case "A": c = 2
                     Case "B": c = 3
                     Case "C": c = 4
                     Case "D": c = 5
                     Case "E": c = 6
                     Case "F": c = 7
                     Case "G": c = 8
                  End Select
                  r = .Cells(.Rows.Count, c).End(xlUp).Row + 1 '記入位置行番号
                  If r < i Then r = i
                  .Cells(r, c).Value = Sheets("予定入力").Cells(m, 2).Value '現場名
                  m = m + 1
               Loop While Sheets("予定入力").Cells(m, 1).Value = D
            End If
            .Cells(i, 1).Value = Format(D, "m/d (aaa)") '日付Set
            D = D + 1
         Next
      End With
 End Sub
 (暇人)

 InputBox で、開始日を指定するサンプルです。私ならこちらをお勧めします。

 Sub 予定D() 
   Dim i&, j&, n&, r&, c&, Str&, D As Date
   Dim Tar&, m
      D = Application.InputBox(prompt:="転記開始日を記入してください ex 2013/m/d", _
                           Default:=Year(Date) & "/", Type:=1)
      If D < 40000 Then MsgBox "再入力してください": Exit Sub
      With Sheets("予定表")
         .Cells.Font.Color = xlGeneral
         .Range("a2:h50").ClearContents
         For i = 2 To 44 Step 7
            .Cells(i, 1).Value = D
            If Weekday(D) = 1 Then .Cells(i, 1).Font.Color = vbRed '土日着色
            If Weekday(D) = 7 Then .Cells(i, 1).Font.Color = vbBlue
            m = Application.Match(CLng(D), Sheets("予定入力").Columns(1), 0)
            If Not IsError(m) Then
               Do
                  Select Case Sheets("予定入力").Cells(m, 3).Value
                     Case "A": c = 2
                     Case "B": c = 3
                     Case "C": c = 4
                     Case "D": c = 5
                     Case "E": c = 6
                     Case "F": c = 7
                     Case "G": c = 8
                  End Select
                  r = .Cells(.Rows.Count, c).End(xlUp).Row + 1 '記入位置行番号
                  If r < i Then r = i
                  .Cells(r, c).Value = Sheets("予定入力").Cells(m, 2).Value '現場名
                  m = m + 1
               Loop While Sheets("予定入力").Cells(m, 1).Value = D
            End If
            .Cells(i, 1).Value = Format(D, "m/d (aaa)") '日付Set
            D = D + 1
         Next
      End With
 End Sub
 (暇人)

暇人様

お返事遅くなり申し訳ございません。

メッセージボックスタイプの物が希望通りでした。

ありがとうございます。

VBAもっと勉強してみます。（ナッツ）

コメント返信：

[ 一覧(最新更新順) ]

[[20130517154919]] 『値が入っているとその下のセルへ代入される方法』（ナッツ） ページの最後に飛ぶ

[[20130517154919]]　『値が入っているとその下のセルへ代入される方法』（ナッツ）　ページの最後に飛ぶ