Excel VBA質問箱 IV

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

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


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

35502 / 76732

←次へ　｜　前へ→


	【46429】Re:重複データの加工について

ponpon - 07/2/2(金) 23:30 -


	引用なし

	パスワード

dictionaryの練習に作ってみました。 sheet1に　　　　A　　　　B　　　　C　　　　D 1　　　　氏名　　　　住所　　　　支払い金額　　　　振込口座 2　　　　A　　　　福岡県　　　　20000　　　　000123456 3　　　　B　　　　大分県　　　　30000　　　　002345678 4　　　　C　　　　佐賀県　　　　30000　　　　003456789 5　　　　D　　　　北海道　　　　50000　　　　005677821 6　　　　A　　　　福岡県　　　　40000　　　　000123456 7　　　　E　　　　東京都　　　　20000　　　　009876532 8　　　　B　　　　大分県　　　　10000　　　　002345678 9　　　　F　　　　静岡県　　　　20000　　　　000435621 10　　　　A　　　　福岡県　　　　20000　　　　000123456 11　　　　G　　　　新潟県　　　　70000　　　　000986789 12　　　　A　　　　福岡県　　　　20000　　　　000123456 13　　　　H　　　　福島県　　　　30000　　　　009684522 14　　　　I　　　　三重県　　　　40000　　　　056783423 15　　　　D　　　　北海道　　　　50000　　　　005677821 16　　　　J　　　　愛媛県　　　　10000　　　　000243627 17　　　　D　　　　北海道　　　　50000　　　　005677821 18　　　　K　　　　秋田県　　　　10000　　　　024246457 19　　　　E　　　　東京都　　　　20000　　　　009876532 20　　　　L　　　　広島県　　　　35000　　　　057645784 21　　　　M　　　　大阪府　　　　28000　　　　056457358 22　　　　E　　　　東京都　　　　20000　　　　009876532 このようなデータがあるとして結果は　　　　A　　　　B　　　　C　　　　D 1　　　　氏名　　　　住所　　　　支払い金額　　　　振込口座 2　　　　A　　　　福岡県　　　　100000　　　　000123456 3　　　　B　　　　大分県　　　　40000　　　　002345678 4　　　　C　　　　佐賀県　　　　30000　　　　003456789 5　　　　D　　　　北海道　　　　150000　　　　005677821 6　　　　E　　　　東京都　　　　60000　　　　009876532 7　　　　F　　　　静岡県　　　　20000　　　　000435621 8　　　　G　　　　新潟県　　　　70000　　　　000986789 9　　　　H　　　　福島県　　　　30000　　　　009684522 10　　　　I　　　　三重県　　　　40000　　　　056783423 11　　　　J　　　　愛媛県　　　　10000　　　　000243627 12　　　　K　　　　秋田県　　　　10000　　　　024246457 13　　　　L　　　　広島県　　　　35000　　　　057645784 14　　　　M　　　　大阪府　　　　28000　　　　056457358 のような感じになります。コードは、 Sub test() 　　Dim myDic As Object 　　Dim myR As Range, r As Range 　　Dim myVal As Variant 　　Dim myAry(3) As Variant 　　　　Application.ScreenUpdating = False 　　With Sheets("Sheet1") 　　　　myVal = .Range("A1").Resize(, 4).Value 　　　　Set myDic = CreateObject("Scripting.Dictionary") 　　　　Set myR = .Range("A2", .Range("A65536").End(xlUp)) 　　　　　　　　For Each r In myR 　　　　　 If Not myDic.Exists(r.Value & r.Offset(, 3).Value) Then 　　　　　　　myAry(0) = r.Value 　　　　　　　myAry(1) = r.Offset(, 1).Value 　　　　　　　myAry(2) = r.Offset(, 2).Value 　　　　　　　myAry(3) = r.Offset(, 3).Value 　　　　　　　myDic(r.Value & r.Offset(, 3).Value) = myAry 　　　　　 Else 　　　　　　　myAry(0) = r.Value 　　　　　　　myAry(1) = r.Offset(, 1).Value 　　　　　　　myAry(2) = myDic(r.Value & r.Offset(, 3).Value)(2) + r.Offset(, 2).Value 　　　　　　　myAry(3) = r.Offset(, 3).Value 　　　　　　　myDic(r.Value & r.Offset(, 3).Value) = myAry 　　　　　 End If 　　　　Next 　　　　.Cells.ClearContents 　　　　With .Range("A1") 　　　　　 .Resize(, 4).Value = myVal 　　　　　 .Offset(1).Resize(myDic.Count, 4).Value = _ 　　　　　 Application.Transpose(Application.Transpose(myDic.items)) 　　　　End With 　　End With 　　Application.ScreenUpdating = True 　　Set myDic = Nothing End Sub "Scripting.Dictionary"で過去ログを検索すれば、いろいろ出てくると思います。参考になればよいのですが・