| |
▼VBAで悩み中 さん：
おはようございます。
nさんがアドバイスされているとおり、この種の処理はPIVOTが最も早いと
思いますし、なによりもコードを書く手間が省けます。ＶＢＡでということなら
そのPIVOT処理をマクロ記録して利用する手もあります。
ただ、私自身、PIVOTを勉強しなきゃ・・とおもいつつ、参考書を１年近く
「積読」状態で、身に付けておりませんので、以下は「力技のコード」です。
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
|
|
UO3
- 11/1/18(火) 10:49 -
