Ｐａｇｅ 699 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼条件を変えて別シート別表に。 hana 03/1/30(木) 17:35 ┗Re:条件を変えて別シート別表に。 ポンタ 03/1/31(金) 8:43 ┗Re:条件を変えて別シート別表に。 hana 03/2/2(日) 0:23 ┗Re:条件を変えて別シート別表に。 ポンタ 03/2/2(日) 8:45 ┗Re:条件を変えて別シート別表に。 hana 03/2/2(日) 22:37 ┗Re:条件を変えて別シート別表に。 ポンタ 03/2/3(月) 14:25 ┗Re:条件を変えて別シート別表に。 hana 03/2/4(火) 14:35 ┗Re:条件を変えて別シート別表に。 ポンタ 03/2/5(水) 10:17 ┗ありがとうございました！ hana 03/2/7(金) 15:28 ─────────────────────────────────────── ■題名 ： 条件を変えて別シート別表に。 ■名前 ： hana ■日付 ： 03/1/30(木) 17:35 -------------------------------------------------------------------------
| いつもお世話になっております・・。 1 2 3 4 5 ・・・・・ 1 日付 コードNO. 店名 コードNO. 店名 ・・ ______________________________________________ 2 ｜ 鈴 木 ｜ 田 中 ｜ ・ ＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿____ 3 1/1 ｜ 1111 ｜A店 ｜ 2222 ｜B店 ｜・・ ＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿＿ 4 1/2 ｜ 2222 ｜B店 | 3333 ｜C店 ｜・・ ・ ・ 行に日付・列に人名の表で、コード番号を入力すると店名が VLOOKUP関数で入る上記の様なシフト表があります。これを元に 今度はお店毎に何日に誰が入店予定かをまとめたいのです。 別シートに書き出し、店別のスケジュール表を別に作成 したいと考えています。どのような方法があるでしょうか？ |
| Sheet1という名前のシートを集計して、 Sheet2という名前のシートに店別のスケジュール表を作成します。 シート名は Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") を環境に合わせて書き換えてください。 標準モジュールに貼り付けて、お試しください。 Sub test() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim i As Long, j As Integer Dim MyRange As Range Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Ws2.Cells.ClearContents For i = 3 To Ws1.Range("A65536").End(xlUp).Row Ws2.Cells(i, 1).Value = Ws1.Cells(i, 1).Value For j = 2 To Ws1.Cells(i, 256).End(xlToLeft).Column Step 2 Set MyRange = Ws2.Range("C1", Ws2.Range("IV1").End(xlToLeft)).Find(Ws1.Cells(i, j).Value) If MyRange Is Nothing Then If Ws2.Range("B1").Value = "" Then Set MyRange = Ws2.Range("B1") Else Set MyRange = Ws2.Range("IV1").End(xlToLeft).Offset(0, 1) End If End If MyRange.Value = Ws1.Cells(i, j).Value MyRange.Offset(1, 0).Value = Ws1.Cells(i, j + 1).Value Ws2.Cells(i, MyRange.Column).Value = Ws1.Cells(2, j).Value Next Next With Ws2 Set MyRange = .Cells(.Range("A65536").End(xlUp).Row _ , .Range("IV1").End(xlToLeft).Column) .Range(.Cells(1, 2), MyRange).Sort key1:=.Range("B1"), Orientation:=xlSortRows, SortMethod:=xlPinYin End With End Sub |
| ▼ポンタ さん： >Sheet1という名前のシートを集計して、 >Sheet2という名前のシートに店別のスケジュール表を作成します。 > >シート名は > Set Ws1 = Worksheets("Sheet1") > Set Ws2 = Worksheets("Sheet2") >を環境に合わせて書き換えてください。 > >標準モジュールに貼り付けて、お試しください。 > > >Sub test() > Dim Ws1 As Worksheet, Ws2 As Worksheet > Dim i As Long, j As Integer > Dim MyRange As Range > Set Ws1 = Worksheets("Sheet1") > Set Ws2 = Worksheets("Sheet2") > Ws2.Cells.ClearContents > For i = 3 To Ws1.Range("A65536").End(xlUp).Row > Ws2.Cells(i, 1).Value = Ws1.Cells(i, 1).Value > For j = 2 To Ws1.Cells(i, 256).End(xlToLeft).Column Step 2 > Set MyRange = Ws2.Range("C1", Ws2.Range("IV1").End(xlToLeft)).Find(Ws1.Cells(i, j).Value) > If MyRange Is Nothing Then > If Ws2.Range("B1").Value = "" Then > Set MyRange = Ws2.Range("B1") > Else > Set MyRange = Ws2.Range("IV1").End(xlToLeft).Offset(0, 1) > End If > End If > MyRange.Value = Ws1.Cells(i, j).Value > MyRange.Offset(1, 0).Value = Ws1.Cells(i, j + 1).Value > Ws2.Cells(i, MyRange.Column).Value = Ws1.Cells(2, j).Value > Next > Next > With Ws2 > Set MyRange = .Cells(.Range("A65536").End(xlUp).Row _ > , .Range("IV1").End(xlToLeft).Column) > .Range(.Cells(1, 2), MyRange).Sort key1:=.Range("B1"), Orientation:=xlSortRows, SortMethod:=xlPinYin > End With >End Sub ポンタ様、本当にいつもありがとうございます。このコードでばっちり 動いたので感動しました！ですが・・実際の範囲などに当てはめようと 丸2日あがきましがデバッグの嵐に打ちひしがれました・・。図々しく て申し訳ございませんがアレンジすべき箇所をご指摘頂けないでしょうか？ 実際の元のシートの状態はF8〜F38（F列）に日付、6行目のI6〜BN6に 人名、I8〜BN38は2行くくりで左コード・右店名,G・H列と7行目は無視 すべき箇所になるのですが・・。 |
| これでどうでしょう？ Sub test() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim i As Long, j As Integer Dim MyRange As Range Set Ws1 = Worksheets("Sheet1") Set Ws2 = Worksheets("Sheet2") Ws2.Cells.ClearContents For i = 8 To Ws1.Range("F65536").End(xlUp).Row Ws2.Cells(i - 5, 1).Value = Ws1.Cells(i, 6).Value For j = 7 To Ws1.Cells(i, 256).End(xlToLeft).Column Step 2 Set MyRange = Ws2.Range("C1", Ws2.Range("IV1").End(xlToLeft)).Find(Ws1.Cells(i, j).Value) If MyRange Is Nothing Then If Ws2.Range("B1").Value = "" Then Set MyRange = Ws2.Range("B1") Else Set MyRange = Ws2.Range("IV1").End(xlToLeft).Offset(0, 1) End If End If MyRange.Value = Ws1.Cells(i, j).Value MyRange.Offset(1, 0).Value = Ws1.Cells(i, j + 1).Value Ws2.Cells(i - 5, MyRange.Column).Value = Ws1.Cells(7, j).Value Next Next With Ws2 Set MyRange = .Cells(.Range("A65536").End(xlUp).Row _ , .Range("IV1").End(xlToLeft).Column) .Range(.Cells(1, 2), MyRange).Sort key1:=.Range("B1"), Orientation:=xlSortRows, SortMethod:=xlPinYin End With End Sub |
| ポンタ様 色々と親切丁寧にご指導頂きましていつも感謝しております。 やっとコードを少し理解できた気がします。今は下記の様になって いまして、なんとなく”店別シート”に書き出してはいるのですが、 中途半端にあったりなかったりの状態です。同じ日付、同じ店に、 複数人の場合などがあるのが問題なのでしょうか？また、同時並行 で教えて頂いているフォームからの入力の様にアルファベット混じり のコードは読み込まないみたいなのですが・・・。 Sub 店別() Dim Ws1 As Worksheet, Ws2 As Worksheet Dim i As Long, j As Integer Dim MyRange As Range Set Ws1 = Worksheets("入力") Set Ws2 = Worksheets("店別") Ws2.Cells.ClearContents For i = 8 To Ws1.Range("F65536").End(xlUp).Row Ws2.Cells(i - 5, 1).Value = Ws1.Cells(i, 6).Value For j = 9 To Ws1.Cells(i, 256).End(xlToLeft).Column Step 2 Set MyRange = Ws2.Range("C1", Ws2.Range("IV1").End(xlToLeft)).Find(Ws1.Cells(i, j).Value) If MyRange Is Nothing Then If Ws2.Range("B1").Value = "" Then Set MyRange = Ws2.Range("B1") Else Set MyRange = Ws2.Range("IV1").End(xlToLeft).Offset(0, 1) End If End If MyRange.Value = Ws1.Cells(i, j).Value MyRange.Offset(1, 0).Value = Ws1.Cells(i, j + 1).Value Ws2.Cells(i - 5, MyRange.Column).Value = Ws1.Cells(6, j).Value Next Next With Ws2 Set MyRange = .Cells(.Range("A65536").End(xlUp).Row _ , .Range("IV1").End(xlToLeft).Column) .Range(.Cells(1, 2), MyRange).Sort Key1:=.Range("B1"), Orientation:=xlSortRows, SortMethod:=xlPinYin End With End Sub |
| Ws2.Cells(i - 5, MyRange.Column).Value = Ws1.Cells(6, j).Value Next この2行の間に Set MyRange = Nothing を入れて、 Ws2.Cells(i - 5, MyRange.Column).Value = Ws1.Cells(6, j).Value Set MyRange = Nothing Next としてみてください。 |
| 色々丁寧に教えていただきありがとうございます。大変 お世話になっております。 下のようにしてみましたがどうしてもできません・・。 ブレークポイントを設定して見てみたのですが、1行目（１日目） はきれいに書き出しているようですが、2行目から書き出したり 無視したりしているような気がします・・。また、ソート後の 最終列に人名の最終列が書き出されてしまいます。自分で手直し できれば良いのですが、よくわかりません。。またお力を貸して 頂けないでしょうか？ ▼ポンタ さん： > Ws2.Cells(i - 5, MyRange.Column).Value = Ws1.Cells(6, j).Value >Next > >この2行の間に > >Set MyRange = Nothing > >を入れて、 > > Ws2.Cells(i - 5, MyRange.Column).Value = Ws1.Cells(6, j).Value > Set MyRange = Nothing >Next > >としてみてください。 |
| 外に出してもいいデータなら、メールしていただけませんか？ (封筒マークをクリックして下さい) 分かる範囲で、ぼちぼち調べてはいるんですが・・・。 |
| ポンタ様 完璧です！ この度はありがとうございました！ 尊敬してます。 |