|
▼MIRURU さん:
参考まで、Dictionaryを使ったサンプルです。
ちょっと工夫したのは
「NAME + BUSHO + CODE + TYPE」 を連結してキー文字列を作り出す方法です。
上の4列をCopyすると、クリップボードに Tab区切りのテキストとして格納さ
れますから、これをDataObject経由で取得し、各行のKeyとして 使っています
Sub Try1()
Dim rv()
Dim r As Range
Dim dKeys, hdr, vv
Dim i&, j&, k&, kk&
Dim ss$
Dim dic As Object
Const CLSID_DataObject = "1C3B4210-F441-11CE-B9EA-00AA006B1A69"
Set dic = CreateObject("Scripting.Dictionary")
With Worksheets("data")
Set r = .Range(.[A2], .[A65536].End(xlUp)) 'A列データ範囲
ReDim rv(1 To 6, r.Rows.Count)
hdr = .[A1].Resize(, 6).Value
For j = 1 To 6
rv(j, 0) = hdr(1, j)
Next
End With
vv = r.Resize(, 6).Value
r.Offset(, 1).Resize(, 4).Copy '「NAME BUSHO CODE TYPE」列を
With GetObject("new:" & CLSID_DataObject) 'クリップボードへ送り
.GetFromClipboard
dKeys = Split(.GetText(1), vbCrLf) '結合文字列を作成
Application.CutCopyMode = True
End With
For i = 1 To UBound(vv)
ss = dKeys(i - 1)
If dic.Exists(ss) Then
k = dic(ss)
Else
kk = kk + 1 'はじめてのKeyのときは
dic(ss) = kk '配列内の行番号を決め
k = kk
For j = 1 To 5 '配列に1〜5列のデータを転記
rv(j, k) = vv(i, j)
Next
End If
rv(6, k) = rv(6, k) + vv(i, 6) 'k番目のKey data 集計
Next
Set dic = Nothing
' ReDim Preserve rv(1 To 6, kk)
With Worksheets("data編集").[A1]
.CurrentRegion.ClearContents
.Resize(kk + 1, 6).Value = Application.Transpose(rv)
End With
End Sub
|
|