Excel VBA質問箱 IV

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

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


255 / 75426 ←次へ | 前へ→

【80821】Re:[無題]
発言  マナ  - 19/5/17(金) 19:24 -

引用なし
パスワード
   ▼しいな さん:

あくまで、たたき台です。
要望と違う部分は、修正してください。

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

47 hits

【80816】[無題] しいな 19/5/16(木) 22:14 質問[未読]
【80817】Re:[無題] マナ 19/5/16(木) 23:04 発言[未読]
【80819】Re:[無題] マナ 19/5/16(木) 23:48 発言[未読]
【80820】Re:[無題] しいな 19/5/17(金) 9:16 質問[未読]
【80821】Re:[無題] マナ 19/5/17(金) 19:24 発言[未読]
【80823】Re:[無題] マナ 19/5/17(金) 21:55 発言[未読]
【80832】Re:[無題] しいな 19/5/19(日) 22:53 お礼[未読]

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