Excel VBA質問箱 IV

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

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


14299 / 76738 ←次へ | 前へ→

【67938】Re:VBAのデータ振り方について
回答  UO3  - 11/1/18(火) 10:49 -

引用なし
パスワード
   ▼VBAで悩み中 さん:

おはようございます。

nさんがアドバイスされているとおり、この種の処理はPIVOTが最も早いと
思いますし、なによりもコードを書く手間が省けます。VBAでということなら
そのPIVOT処理をマクロ記録して利用する手もあります。

ただ、私自身、PIVOTを勉強しなきゃ・・とおもいつつ、参考書を1年近く
「積読」状態で、身に付けておりませんので、以下は「力技のコード」です。

Option Explicit

Sub Sample()
  Dim dicCName As Object
  Dim dicList As Object
  Dim ListV() As Variant
  Dim dataV As Variant
  Dim x As Long, y As Long
  Dim i As Long
  Dim cntWeek As Long, cntCharge As Long
  Dim c As Range, d As Range
  Dim myKey As String
  Dim shN As Worksheet
  
  Application.ScreenUpdating = False
  
  Set dicCName = CreateObject("Scripting.Dictionary")
  Set dicList = CreateObject("Scripting.Dictionary")
  
  With Worksheets("Sheet1")  '<== 実際のシート名に
    x = .Range("A1").CurrentRegion.Columns.Count
    y = .Range("A1").CurrentRegion.Rows.Count
    cntCharge = 4  '新シートのチャージのセット開始列
    For Each c In .Range("C2:C" & y) 'チャージの抽出
      If Not dicCName.exists(c.Value) Then
        dicCName(c.Value) = cntCharge
        cntCharge = cntCharge + 1
      End If
    Next
    cntCharge = cntCharge - 1
    ReDim ListV(1 To cntCharge)
    For Each c In .Range("A2:A" & y)
      cntWeek = 1
      For Each d In c.Offset(, 3).Resize(, x - 3)
        If d.Value <> 0 Then
          myKey = c.Value & vbTab & cntWeek
          If Not dicList.exists(myKey) Then
            ListV(1) = c.Value
            ListV(2) = c.Offset(, 1).Value
            ListV(3) = cntWeek
            dicList(myKey) = ListV
          End If
          dataV = dicList(myKey)
          dataV(dicCName(c.Offset(, 2).Value)) = _
          dataV(dicCName(c.Offset(, 2).Value)) + d.Value
          dicList(myKey) = dataV
        End If
        cntWeek = cntWeek + 1
      Next
    Next
    '新シートを準備
    Set shN = Sheets.Add
    .Cells.Copy
  End With
  
  With shN
    '新シートに元シートの書式と列幅をコピー
    .Range("A1").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
    .Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
    'タイトル行作成
    .Range("A1:C1").Value = Array("社員ID", "氏名", "Week")
    .Range("D1").Resize(, dicCName.Count).Value = dicCName.keys
    '処理結果を転記
    .Range("A2").Resize(dicList.Count, cntCharge).Value = _
      WorksheetFunction.Transpose(WorksheetFunction.Transpose(dicList.items))
    '転記結果の並び替え
    .Cells.Sort Key1:=.Range("A2"), Order1:=xlAscending, Key2:=.Range("C2") _
      , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
      False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
      xlSortNormal, DataOption2:=xlSortNormal
  End With
  
  Set dicList = Nothing
  Set dicCName = Nothing
  Set shN = Nothing
  
  Application.ScreenUpdating = True
    
End Sub
3 hits

【67927】VBAのデータ振り方について VBAで悩み中 11/1/17(月) 15:48 質問
【67931】Re:VBAのデータ振り方について n 11/1/17(月) 18:47 発言
【67938】Re:VBAのデータ振り方について UO3 11/1/18(火) 10:49 回答
【67947】Re:VBAのデータ振り方について VBAで悩み中 11/1/18(火) 14:58 お礼

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