Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

56178 / 76732

←次へ　｜　前へ→


	【25312】Re:重複データを一行にまとめる

ponpon - 05/5/27(金) 20:31 -


	引用なし

	パスワード

さくらさん。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

0 hits

▼

【25308】重複データを一行にまとめる さくら 05/5/27(金) 14:41