Excel VBA質問箱 IV

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

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


51206 / 76738 ←次へ | 前へ→

【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

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

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