| |
▼しいな さん：
あくまで、たたき台です。
要望と違う部分は、修正してください。
Option Explicit
Sub test2()
Dim dic As Object
Dim ws As Worksheet
Dim c As Range
Dim e
Dim n As Long
Dim r As Range
Dim fn
Dim pvt As PivotTable
Set dic = CreateObject("scripting.dictionary")
Set ws = ActiveSheet
For Each c In ws.Range("a1", ws.Range("a10000").End(xlUp))
For Each e In Split(c.Offset(, 2).Value, ";")
n = n + 1
dic(n) = Array(c.Value, c.Offset(, 1).Value, e)
Next
Next
With ws.Cells(5)
.CurrentRegion.ClearContents
.Resize(n, 3).Value = Application.Index(dic.items, 0, 0)
Set r = .CurrentRegion
End With
fn = Application.Index(r.Value, 1)
With ws.Cells(9)
On Error Resume Next
.PivotTable.TableRange2.ClearContents
On Error GoTo 0
Set pvt = .Parent.Parent.PivotCaches.Create(xlDatabase, r).CreatePivotTable(.Cells)
End With
With pvt
.RowAxisLayout xlTabularRow
.RowGrand = False
.ColumnGrand = False
.AddDataField .PivotFields(fn(2)), fn(2) & " ", xlCount
.AddFields PageFields:=fn(2), RowFields:=fn(3), ColumnFields:=fn(1)
End With
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
