人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセル2007を使用しています。
A列で25000件のデータをマッチングして同一キーとそうでないものに分けたいのですがマクロで実行する方法を教えてください。

●質問者: inosisi
●カテゴリ:コンピュータ インターネット
✍キーワード:いもの エクセル キー データ マクロ
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●10ポイント

具体的にマッチングさせるデータがどこにあるとか、分ける方法について書いてないので

あくまで参考になりますが、だいたい1行づつループさせてFindで調べるという感じになると思います。

下記のコードはデータをA列、マッチングデータがC列として、B列に○×をつけるマクロです。

分けたデータを取り出したい場合はB列でソートすればいいです。

Sub Macro()
 Dim i As Long
 Dim lastRow As Long
 Dim obj As Object
 
 lastRow = Cells(Rows.Count, "A").End(xlUp).Row
 
 For i = 1 To lastRow
 If Cells(i, "A").Value = "" Then
 Cells(i, "B").Value = ""
 Else
 Set obj = Range("C:C").Find(Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
 If Not obj Is Nothing Then
 Cells(i, "B").Value = "○"
 Else
 Cells(i, "B").Value = "×"
 End If
 End If
 Next i
End Sub
◎質問者からの返答

ありがとうございます。

結果はOKです。

できればC列の合致分がA列と同じ位置にあればわかりやすいのですがよろしくおねがいします。

A列に25000件?30000件C列に5000件?10000件のデータを想定しています。

aaa ×

bbb ○ bbb

ccc ○ ccc

ddd ×


2 ● SALINGER
●60ポイント ベストアンサー

それならば、○×はやめてB列にC列から値を持ってくるようにしてみてはどうでしょう。

aaa bbb
bbb bbb ccc
ccc ccc
ddd

こんな感じです。

Sub Macro()
 Dim i As Long
 Dim lastRow As Long
 Dim obj As Object
 
 lastRow = Cells(Rows.Count, "A").End(xlUp).Row
 
 For i = 1 To lastRow
 If Cells(i, "A").Value = "" Then
 Cells(i, "B").Value = ""
 Else
 Set obj = Range("C:C").Find(Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
 If Not obj Is Nothing Then
 Cells(i, "B").Value = obj.Value
 Else
 Cells(i, "B").Value = ""
 End If
 End If
 Next i
End Sub
◎質問者からの返答

早速ありがとうございます。

どちらか使い方を考えてみます。

もうひとつ問題を定義するのを忘れていました。

A列およびC列に重複キーが含まれていた場合の処理を考え

ていただきたいのですが

できれば重複キーは削除せず色とマークで判別できるとよい

のですが

aaa aaa bbb

aaa aaa aaa

bbb bbb ccc

ccc ccc aaa

ddd


3 ● nanntenn
●30ポイント

「一人当たり2回まで」の制限でSALINGERさんはこれ以上回答できないので代わりに作成してみました。

A列の重複は「青の太字」、C列の重複は「赤の太字」で区別するマクロです。


Sub Macro()
 Dim i As Long
 Dim lastRow As Long
 Dim obj1 As Object, obj2 As Object, obj3 As Object, obj4 As Object
 
 lastRow = Cells(Rows.Count, "A").End(xlUp).Row
 
 For i = 1 To lastRow
 
 If Cells(i, "A").Value = "" Then
 Cells(i, "B").Value = ""
 Else
  'C列を検索する
 Set obj1 = Range("C:C").Find(Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
 If Not obj1 Is Nothing Then
 Cells(i, "B").Value = obj1.Value
 
  'C列を続けて検索する
 Set obj2 = obj1
 Do
 Set obj2 = Range("C:C").FindNext(after:=obj2)
 If obj2.Address = obj1.Address Then Exit Do 'アドレスが最初に戻ったらループを抜ける
 
   If Range(obj2.Address).Row > Range(obj1.Address).Row Then
 obj2.Font.ColorIndex = 3: obj2.Font.Bold = True '赤の太字に
   Else
 obj1.Font.ColorIndex = 3: obj1.Font.Bold = True
 End If
 Loop
 Set obj1 = Nothing: Set obj2 = Nothing
 Else
 Cells(i, "B").Value = ""
 End If
 
  'A列の重複をチェック
 Set obj3 = Range("A:A").Find(Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole, after:=Cells(1, "A"))
 Set obj4 = obj3
 Do
 Set obj4 = Range("A:A").FindNext(after:=obj4)
 If obj4.Address = obj3.Address Then Exit Do '最初に戻ったらループを抜ける
 
 If Range(obj4.Address).Row > Range(obj3.Address).Row Then
 obj4.Font.ColorIndex = 5: obj4.Font.Bold = True '青の太字に
 Else
 obj3.Font.ColorIndex = 5: obj3.Font.Bold = True
 End If
 Loop
 Set obj3 = Nothing: Set obj4 = Nothing
 End If
 Next i
End Sub
◎質問者からの返答

ありがとうございました。

助かれました。

SALINGERさんには申し訳けありませんでした。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ