| |
仮に１表があるシートを Sheet1 として、Sheet2 に２表を作るとします。
以下のようなコードで出来ると思います。
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
|
|
Kein
- 07/1/14(日) 4:07 -
