エクセルで下記の動作をマクロで行って欲しいのですが

どのようなコードで作成すれば良いのでしょうか?
ポイントは実用的だった回答の方に配分します。

エクセルのBOOK AとBOOK Bがあります。
比較したい値は下記となっています。
BOOKA
worksheetA
セルA 番号A
セルD 番号B

BOOKB
worksheetA
セルE 番号B


BOOKBのセルEとBOOK AのセルDを比較して、同じ値なら
BOOKBのセルQにBOOKAの同列の番号Aを代入し、セルRに番号Aの数を
カウントし代入したい。
結果が複数の場合は、番号Aを「/」で区切りたい

例)
BOOK A
セルA セルD
1   123
2   224
3   123
4   555
5   455

BOOK B
セルE
100
123
214
224
318
455
500
515
555

----------------
マクロの結果

BOOK B
セルE セルQ セルR
100
123  1/3  2
214
224  2   1
318
455  5   1
500
515
555  4   1

回答の条件
  • 1人2回まで
  • 登録:2009/10/12 18:25:13
  • 終了:2009/10/12 20:11:25

ベストアンサー

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/10/12 18:57:09

ポイント100pt

一応仕様通りにしたつもりですが、異なる点がありましたらコメントにて対応しますので、

コメントを有効にお願いいたします。


処理毎に Q、R 列を初期化しますので、必要に応じてファイルを保存してください。

Sub CompAndCount()
    Dim refWS As Worksheet
    Set refWS = Workbooks("BOOKA.xls").Worksheets("Sheet1")
    
    Dim chkWS As Worksheet
    Set chkWS = Workbooks("BOOKB.xls").Worksheets("Sheet1")

    Dim r As Long
    Dim lastRow As Long
    lastRow = chkWS.Range("E" & Rows.Count).End(xlUp).Row
    
    chkWS.Columns("Q:R") = ""
    chkWS.Columns("Q:R").NumberFormatLocal = "@"
    
    
    Dim fr As Range
    Dim rr As Range
    For r = 2 To lastRow
        Set fr = refWS.Columns("D").Find(what:=chkWS.Cells(r, "E").Value, lookat:=xlWhole)
        If Not fr Is Nothing Then
            Set rr = fr
            Do
                If chkWS.Cells(r, "Q") = "" Then
                    chkWS.Cells(r, "Q") = refWS.Cells(fr.Row, "A").Value
                    chkWS.Cells(r, "R") = 1
                Else
                    chkWS.Cells(r, "Q") = chkWS.Cells(r, "Q") & "/" & refWS.Cells(fr.Row, "A").Value
                    chkWS.Cells(r, "R") = chkWS.Cells(r, "R") + 1
                End If
                Set fr = refWS.Columns("D").FindNext(fr)
            Loop While fr.Address <> rr.Address
        End If
    Next
End Sub
id:omoro

さっそくの回答ありがとうございます。

ほぼ期待動作通りなのですが、1行目だけ結果が

Q、Rに表示されないのですが、なぜでしょうか?

2009/10/12 20:07:04

その他の回答(1件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912009/10/12 18:57:09ここでベストアンサー

ポイント100pt

一応仕様通りにしたつもりですが、異なる点がありましたらコメントにて対応しますので、

コメントを有効にお願いいたします。


処理毎に Q、R 列を初期化しますので、必要に応じてファイルを保存してください。

Sub CompAndCount()
    Dim refWS As Worksheet
    Set refWS = Workbooks("BOOKA.xls").Worksheets("Sheet1")
    
    Dim chkWS As Worksheet
    Set chkWS = Workbooks("BOOKB.xls").Worksheets("Sheet1")

    Dim r As Long
    Dim lastRow As Long
    lastRow = chkWS.Range("E" & Rows.Count).End(xlUp).Row
    
    chkWS.Columns("Q:R") = ""
    chkWS.Columns("Q:R").NumberFormatLocal = "@"
    
    
    Dim fr As Range
    Dim rr As Range
    For r = 2 To lastRow
        Set fr = refWS.Columns("D").Find(what:=chkWS.Cells(r, "E").Value, lookat:=xlWhole)
        If Not fr Is Nothing Then
            Set rr = fr
            Do
                If chkWS.Cells(r, "Q") = "" Then
                    chkWS.Cells(r, "Q") = refWS.Cells(fr.Row, "A").Value
                    chkWS.Cells(r, "R") = 1
                Else
                    chkWS.Cells(r, "Q") = chkWS.Cells(r, "Q") & "/" & refWS.Cells(fr.Row, "A").Value
                    chkWS.Cells(r, "R") = chkWS.Cells(r, "R") + 1
                End If
                Set fr = refWS.Columns("D").FindNext(fr)
            Loop While fr.Address <> rr.Address
        End If
    Next
End Sub
id:omoro

さっそくの回答ありがとうございます。

ほぼ期待動作通りなのですが、1行目だけ結果が

Q、Rに表示されないのですが、なぜでしょうか?

2009/10/12 20:07:04
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/10/12 19:02:51

ポイント50pt

こんな感じでどうでしょうか。

BOOKBとBOOKAを開いてどちらかの標準モジュールから実行してください。


Sub Macro()
    Dim wsA As Worksheet
    Dim wsB As Worksheet
    Dim lastRowA As Long
    Dim lastRowB As Long
    Dim i As Long
    Dim j As Long
    
    Set wsA = Workbooks("BOOKA.xls").Worksheets("worksheetA")
    Set wsB = Workbooks("BOOKB.xls").Worksheets("worksheetA")
    
    lastRowA = wsA.Cells(Rows.count, "A").End(xlUp).Row
    lastRowB = wsB.Cells(Rows.count, "E").End(xlUp).Row
    
    For i = 1 To lastRowB
        For j = 1 To lastRowA
            If wsB.Cells(i, "E").Value = wsA.Cells(j, "D").Value Then
                If wsB.Cells(i, "Q").Value = "" Then
                    wsB.Cells(i, "Q").NumberFormatLocal = "@"
                    wsB.Cells(i, "Q").Value = wsA.Cells(j, "A").Value
                Else
                    wsB.Cells(i, "Q").Value = wsB.Cells(i, "Q").Value & "/" & wsA.Cells(j, "A").Value
                End If
                wsB.Cells(i, "R").Value = wsB.Cells(i, "R").Value + 1
            End If
        Next j
    Next i
End Sub
id:omoro

さっそくの回答ありがとうございます。

「wsB.Cells(i, "R").Value = wsB.Cells(i, "R").Value + 1」

で型が一致しません

とエラーが出てしまいました。。

2009/10/12 20:07:11
  • id:omoro
    Mookさん

    自己解決出来ました。
    有難うございました。
    ベストアンサーに選ばせて頂きました。

    SALINGERさんも有難う御座いました。
  • id:Mook
    イルカ賞ありがとうございます。

    解決したようですので、すでにお分かりだと思いますが、
    1行目は勝手にタイトル行と判断し2行目からの処理にしていました。

    失礼しました。
  • id:SALINGER
    >エラーが出てしまいました。。
    ええと、Mookさんのコードの後に実行されたので、R列が文字列となっているためでしょうか。
  • id:Mook
    おぉ、

    chkWS.Columns("Q:R").NumberFormatLocal = "@"

    chkWS.Columns("Q").NumberFormatLocal = "@"
    の方がよいですね。

    重々失礼しました。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません