Excel VBA質問箱 IV

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

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


51271 / 76732 ←次へ | 前へ→

【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

1 hits

【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 お礼

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