|
さくらさん。Hirofumiさん。こんばんは。
HirofumiさんのDictionaryにはかないませんが、
(まだ、Dictionaryは、会得していない)
一応私も作ったので、
フィルタオプションとオートフィルタでやってみました。
>データは千件を超えます。
オートフィルタだから時間がかかると思います。
試してみてください。
1行目には、項目が入っているものとします。
Sub test()
Dim myTbl As Range
Dim myR As Range
Dim myVal As Variant
Application.ScreenUpdating = False
Set myTbl = Worksheets("sheet1").Range("A1").CurrentRegion
Set myR = Worksheets("sheet1").Range("D1")
'A列のユニークな値をD列に書き出す。
myTbl.Columns(1).AdvancedFilter xlFilterCopy, copytorange:=myR, unique:=True
myVal = Range("D2", Range("D65536").End(xlUp)).Value
'オートフィルターで抽出sheet2に転記
For i = 1 To UBound(myVal, 1)
myTbl.AutoFilter field:=1, Criteria1:=myVal(i, 1)
Range("B2", Range("B65536").End(xlUp)).Copy
With Worksheets("sheet2")
.Range("A1:B1").Value = Worksheets("sheet1").Range("A1:B1").Value
.Range("A65536").End(xlUp).Offset(1, 0).Value = myVal(i, 1)
.Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteAll, Transpose:=True
End With
myTbl.AutoFilter
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
|
|