97

view

sunshellsalohaさん、こんにちわ。。

【追記】
やはり、配列処理の方がセルアクセスより早いのですネ。。
もっと勉強しなきゃ…。
「カンニング」の件OKです。わたしも現認しました。。
いつかはみんな間違いなく死んじゃうのだから、「仲良く」しなきゃ！

【最初の回答】
初心者なので、、ちょっとややこかったです。。
ちょっと忙しくって、説明はあとから付けますネ。。

Itemの追加はPreserveキーワードで要素数を1個ずつ増やしていけば出来ました。
でも、最初のKeyを登録するときに「複数のItem」を一気にセットできず、、
1度最初の数値をセットして、Key登録してから上記の要領でItemを追加しました。
ちゃんと理解していないので、試行錯誤でした。。

Sub TRANFER7()
Dim SDATA, myVal As String
Dim DIC As Object
Dim I As Long, myCnt As Long
Dim STR, OTR As String
Dim KEY, k As Long
STR = "A1"
OTR = "A9"
SDATA = Range(STR).CurrentRegion.Value '元のデータを配列に入れる。
Set DIC = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(SDATA) '配列の1列目を上から順に。
myVal = SDATA(I, 1)
myCnt = WorksheetFunction.Count(Rows(I)) '当該行の数値の個数。
If DIC.exists(myVal) Then 'Keyが登録されていたら、
KEY = DIC(myVal) 'KeyをKEYに置き換えて、
For k = 2 To myCnt + 1 '数値の列数分。
ReDim Preserve KEY(UBound(KEY) + 1) 'Itemの要素を1個増やして、
KEY(UBound(KEY)) = SDATA(I, k) '配列中の数値をItemに格納。
Next k
Else 'Keyが登録されていなかったら、
KEY = Array(myVal, SDATA(I, 2)) '1度最初の数値を登録して、
DIC(myVal) = KEY 'DICのKeyに登録して、
For k = 3 To myCnt + 1 '当該行の残りの列数分だけ。
ReDim Preserve KEY(UBound(KEY) + 1) 'Itemの要素を1個増やして、
KEY(UBound(KEY)) = SDATA(I, k) '配列中の数値をItemに格納。
Next k
End If
DIC(myVal) = KEY
Next
Range(OTR).CurrentRegion.ClearContents 'A9の周りのデータをDel。
I = 0
For Each KEY In DIC.Items 'DIC内のKeyを探して、、
I = I + 1
Range(OTR).ITEM(I, 1).Resize(, UBound(KEY) + 1).Value = KEY 'Keyごとに吐き出す。
Next KEY
Range(OTR).CurrentRegion.Borders.LineStyle = xlContinuous '当該範囲に罫線。
Set DIC = Nothing
End Sub