Excel VBA質問箱 IV

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

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


2452 / 13645 ツリー ←次へ | 前へ→

【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 お礼[未読]

【67927】VBAのデータ振り方について
質問  VBAで悩み中  - 11/1/17(月) 15:48 -

引用なし
パスワード
   VBA初心者です。現在下記プログラムを組みたいですが、、なかなかうまくいかなくて、ご存知の方是非教えていただけたらと思います。

内容:
【元データ】(I)
    A     B     C      D   E  F 。。。
1 社員コード name チャージコード  1週目 2週目。。。。。
2 000001   吉田   YI001     20  10
3 000002   横田   GM002     2   8
4 000003   鈴木   YI001     15   20
5 000001   吉田   YM002     12  18
6 000001   吉田   YI001     14  10
7 000003   鈴木   YX002     12  30

【新しいシート】(II)
    A     B     C   D   E  F 。。。
1 社員コード name   week  YI001 YM002
2 000001   吉田    1    34  12
3 000001   吉田    2    20  18
4 ・・・・・・      3    ・・・・・・・
5 000003   鈴木    1    15  0
6 000003   鈴木    2    20  0

元データIを取り込んで、条件によって、新しいシートにIIを作成する。
同じ社員コードの従業員のチャージコード別、週別に集計する。
このような処理のソースはどういう書き方をすればよろしいでしょうか?
宜しく御願いします。

【67931】Re:VBAのデータ振り方について
発言  n  - 11/1/17(月) 18:47 -

引用なし
パスワード
   一度PivotTableを試してみると良いかもしれません。
p://www11.plala.or.jp/koma_Excel/contents3/mame3026/mame302601.html
最終表の体裁にもよりますが、これで足りれば簡単かつ便利です。

【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

【67947】Re:VBAのデータ振り方について
お礼  VBAで悩み中  - 11/1/18(火) 14:58 -

引用なし
パスワード
   ▼UO3 さん:
回答ありがとうございます。
すごく参考になりました。

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