Excel VBA質問箱 IV

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

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


36134 / 76732 ←次へ | 前へ→

【45781】Re:複数行の項目を同一項目で、1行にまとめたい・・・
回答  Kein  - 07/1/14(日) 4:07 -

引用なし
パスワード
   仮に1表があるシートを Sheet1 として、Sheet2 に2表を作るとします。
以下のようなコードで出来ると思います。

Sub Mk_NewTable()
  Dim MyR As Range, C As Range
  Dim i As Integer, j As Integer, MxC As Integer
  Dim ChildCnt() As Integer
  Dim MyCld As Variant
 
  With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
  End With
  With Sheets("Sheet2")
   .Cells.ClearContents
   Sheets("Sheet1").Range("A1").CurrentRegion.Copy .Range("B1")
   .Range("B1").CurrentRegion.Sort Key1:=.Range("B1"), _
   Order1:=xlAscending, key2:=.Range("C1"), Order2:=xlAscending, _
   Header:=xlYes, Orientation:=xlSortColumns
   .Range("A1").Value = "作業Data"
   .Range("B2", .Range("B65536").End(xlUp)).Offset(, -1) _
   .Formula = "=$B2&$C2"
   .Range("A1").CurrentRegion.Subtotal 1, xlCount, Array(3)
   Set MyR = .Range("B2", .Range("B65536").End(xlUp)) _
   .SpecialCells(2)
   For Each C In MyR.Areas
     C.Cells(1).Offset(, 254).Value = 1: j = C.Count
     ReDim Preserve ChildCnt(i): ChildCnt(i) = j: i = i + 1
     If j > 1 Then
      MyCld = WorksheetFunction.Transpose(C.Offset(, 2).Value)
      C.Cells(1).Offset(, 2).Resize(, j).Value = MyCld
     End If
   Next
   .Range("A1").CurrentRegion.RemoveSubtotal
   .Range("A2", .Range("A65536").End(xlUp)).Offset(, 255) _
   .SpecialCells(4).EntireRow.Delete xlShiftUp
   .Range("A:A").Delete xlShiftToLeft
   MxC = WorksheetFunction.Max(ChildCnt)
   .Range("C1").Resize(, MxC).Value = "園児名"
   .Range("A1").Offset(, MxC + 2).Value = "園児数"
   .Range("A2").Offset(, MxC + 2).Resize(UBound(ChildCnt) + 1) _
   .Value = WorksheetFunction.Transpose(ChildCnt)
   .Activate
  End With
  Erase ChildCnt: Set MyR = Nothing
  With Application
   .ScreenUpdating = True
   .DisplayAlerts = True
  End With
End Sub

0 hits

【45777】複数行の項目を同一項目で、1行にまとめたい・・・ NOKO 07/1/14(日) 2:49 質問
【45781】Re:複数行の項目を同一項目で、1行にまと... Kein 07/1/14(日) 4:07 回答
【45783】Re:複数行の項目を同一項目で、1行にまと... Hirofumi 07/1/14(日) 8:41 回答
【45792】Re:複数行の項目を同一項目で、1行にまと... Hirofumi 07/1/14(日) 15:08 回答

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