Excel VBA質問箱 IV

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

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


8903 / 13644 ツリー ←次へ | 前へ→

【30325】初心者な質問で申し訳ございません Duca 05/10/25(火) 14:44 質問[未読]
【30332】Re:初心者な質問で申し訳ございません Kein 05/10/25(火) 15:55 回答[未読]
【30348】Re:初心者な質問で申し訳ございません Duca 05/10/25(火) 17:38 質問[未読]
【30354】Re:初心者な質問で申し訳ございません Kein 05/10/25(火) 18:19 発言[未読]
【30397】Re:初心者な質問で申し訳ございません Duca 05/10/26(水) 17:31 発言[未読]
【30405】Re:初心者な質問で申し訳ございません Kein 05/10/26(水) 21:50 回答[未読]
【30406】Re:初心者な質問で申し訳ございません Kein 05/10/26(水) 21:51 発言[未読]
【30423】Re:初心者な質問で申し訳ございません Duca 05/10/27(木) 11:01 お礼[未読]

【30325】初心者な質問で申し訳ございません
質問  Duca  - 05/10/25(火) 14:44 -

引用なし
パスワード
   初心者中の初心者でお手数をお掛けしますがご教授願います。

例えば
4月19日 山田太郎 15
      鈴木次郎 10
      山田太郎 15

4月20日 山田太郎 10
      山田太郎 15
      鈴木次郎 10
      佐藤花子 20
      山田太郎 15
      鈴木次郎 10

といった表を、
4月19日 山田太郎 30
      鈴木次郎 15

4月20日 山田太郎 40
      鈴木次郎 20
      佐藤花子 20

というように別シートに作りたいのですが初心者ためなにもわかりません・・・。
大変に申し訳ありませんがどなた様かご教授をお願い致します。

【30332】Re:初心者な質問で申し訳ございません
回答  Kein  - 05/10/25(火) 15:55 -

引用なし
パスワード
   仮に Sheet1 にその表があるとして、Sheet2 に集計した表を作ります。
ただし、集計先では元表の日付の上にあった空白行は、詰めて表示します。
コードはこんな感じになります。シートの指定については、そちらで適当に
修正して下さい。

Sub MyTable()
  Dim MyR As Range, C As Range, HdR As Range
  Dim Cnt As Long
 
  Application.ScreenUpdating = False
  With Sheets("Sheet1")
   .Rows(1).Insert xlShiftDown
   Set MyR = .Range("B1", Range("B65536").End(xlUp)) _
   .SpecialCells(2)
  End With
  With Sheets("Sheet2")
   For Each C In MyR.Areas
     Cnt = C.Cells.Count
     Set HdR = C.Cells(1).Offset(-1)
     HdR.Value = "Data"
     HdR.Resize(Cnt + 1).AdvancedFilter xlFilterCopy, , _
     .Range("B65536").End(xlUp).Offset(2), True
     With .Range("B65536").End(xlUp).CurrentRegion
      .Offset(, 1).Formula = _
      "=SUMIF(Sheet1!" & C.Address & "," & _
      .Cells(1).Address(0, 0) & "," & "Sheet1!" & _
      C.Offset(, 1).Address & ")"
      With .Cells(1)
        .Offset(1, -1).Value = _
        C.Cells(1).Offset(, -1).Value
        .Resize(, 2).ClearContents
      End With
     End With
     HdR.ClearContents: Set HdR = Nothing
   Next
   With .Range("C1", .Range("C65536").End(xlUp))
     .Copy
     .PasteSpecial xlPasteValues
     .SpecialCells(4).EntireRow.Delete xlShiftUp
   End With
   .Activate
   .Range("A1").Activate
  End With
  Set MyR = Nothing
  Sheets("Sheet1").Rows(1).Delete xlShiftUp
  With Application
   .CutCopyMode = False
   .ScreenUpdating = True
  End With
End Sub

【30348】Re:初心者な質問で申し訳ございません
質問  Duca  - 05/10/25(火) 17:38 -

引用なし
パスワード
   詳しいご説明・ご教授本当にありがとうございます。

私の知識と説明不足で再度、質問させてください・・・。

ご教授いただいたコードを実行してみたところ、
4月19日    180

4月20日    150
など、名前別ではなく日毎総合計となっておりました。
4月19日 山田 150
      鈴木 30
というようにするためにはどのように手を加えたらよろしいでしょうか。

また、集計表ですが、日によりbookもbook名も変わっていきますので
出来れば、他ファイルから集計表を選択し実行出来るものが理想であります。

拙い知識で手を加えてみましたが
Application.FindFileを加えただけではエラーが起こり最後まで実行出来ませんでした。
せっかくご説明いただいたのにご迷惑をお掛けしますが
お暇があるときにでもよろしかったら再度、ご教授をお願いしたく思います。

【30354】Re:初心者な質問で申し訳ございません
発言  Kein  - 05/10/25(火) 18:19 -

引用なし
パスワード
   提示されたシートのレイアウトが不充分なため、そのような間違った結果に
なるのです。列記号と行番号も含めて、表のサンプルを書いてみて下さい。

【30397】Re:初心者な質問で申し訳ございません
発言  Duca  - 05/10/26(水) 17:31 -

引用なし
パスワード
   お返事ありがとうございます。
説明・情報が浅くて申し訳ありませんでした。
詳しく説明しますと、

    B    C     D    E    F   D   G
9  実施日 大項目 中項目 作業者 予定 残件 合計
___________________________________
10  4月19日             合計  300  10  300
11         ○   △   山田  120  10  120
12          △   ○   山田  100  0   100
13          □   □   鈴木  80   0   80
14  4月20日           合計  10   0   10
15         ○   △   山田  10    0   10


行は無数にあり、列はGまでございますが
必要なものはBの「実施日」とEの「作業者」とGの「合計」です。

何度もすみません。
質問というより、コード作成を依頼しているようなもので本当にお手数をお掛け致します。

【30405】Re:初心者な質問で申し訳ございません
回答  Kein  - 05/10/26(水) 21:50 -

引用なし
パスワード
   これでどうかな ? こちらのテストではうまくいったみたいですが。

Sub My集計()
  Dim MyR As Range, C As Range
  Dim i As Long, j As Long
 
  Set Sh = Worksheets("Sheet2")
  Application.ScreenUpdating = False
  With Worksheets("Sheet1")
   Set MyR = .Range("A10", .Range("A65536").End(xlUp)) _
   .SpecialCells(2, 1)
   For i = MyR.Areas.Count To 2 Step -1
     MyR.Areas(i).EntireRow.Insert xlShiftDown
   Next i
   Set MyR = .Range("D10", .Range("D65536").End(xlUp)) _
   .SpecialCells(2, 2)
  End With
  With Worksheets("Sheet2")
   For Each C In MyR.Areas
     i = .Range("B65536").End(xlUp).Row + 2
     .Cells(i, 1).Value = _
     Format(C.Range("A1").Offset(, -3).Value, "m月d日")
     .Cells(i, 2).Resize(C.Count).Value = C.Value
     .Cells(i, 3).Resize(C.Count).Value = _
     C.Offset(, 3).Value
     .Cells(i, 2).Resize(C.Count, 2).Sort Key1:= _
     .Cells(i, 2), Order1:=xlAscending, Header:=xlYes, _
     Orientation:=xlSortColumns
     For j = (i + C.Count - 1) To (i + 2) Step -1
      If .Cells(j, 2).Value = _
      .Cells(j - 1, 2).Value Then
        .Cells(j - 1, 3).Value = _
        .Cells(j - 1, 3).Value + .Cells(j, 3).Value
        .Rows(j).Delete xlShiftUp
      End If
     Next j
   Next
   .Rows("1:2").Delete xlShiftUp
   .Activate
  End With
  With Worksheets("Sheet1")
   .Range("D10", .Range("D65536").End(xlUp)) _
   .SpecialCells(4).EntireRow.Delete xlShiftUp
  End With
  Application.ScreenUpdating = True: Set MyR = Nothing
End Sub

【30406】Re:初心者な質問で申し訳ございません
発言  Kein  - 05/10/26(水) 21:51 -

引用なし
パスワード
   >Set Sh = Worksheets("Sheet2")
↑これは削除しておいて下さい。あってもエラーにはなりませんが。

【30423】Re:初心者な質問で申し訳ございません
お礼  Duca  - 05/10/27(木) 11:01 -

引用なし
パスワード
   Kein様、本当にありがとうございました。
こちらの思う通りの完璧な表が出来上がりました。

質問の粋を越えたものだったかもしれませんが
快く対応していただき本当に感謝しております。

勉強不足な為、ご迷惑もお掛けしました。
ご教授いただいたコードを確認し、理解し私の教材とさせていただきます。
どうもありがとうございました。

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