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

Question

omoro

196

194もっと見る

150pt

コンピュータ

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

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

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

BOOKB
worksheetA
セルＥ　番号Ｂ

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

※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

No.2

SALINGER34549692009/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

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

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

で型が一致しません

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

2009/10/12 20:07:11

omoro 2009/10/12 20:14:18

Mookさん

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

SALINGERさんも有難う御座いました。
Mook 2009/10/12 20:19:57

イルカ賞ありがとうございます。

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

失礼しました。
SALINGER 2009/10/12 20:22:45

＞エラーが出てしまいました。。
ええと、Mookさんのコードの後に実行されたので、R列が文字列となっているためでしょうか。
Mook 2009/10/12 20:27:50

おぉ、

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

重々失礼しました。

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

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

リクエスト送信済

回答リクエストを送信したユーザーはいません

Mook · Accepted Answer · 2009-10-12T18:57:09+09:00

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

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

処理毎に 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

Mook · Accepted Answer · 2009-10-12T18:57:09+09:00

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

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

処理毎に 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

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

ベストアンサー

Mook13143932009/10/12 18:57:09

その他の回答（1件）

Mook13143932009/10/12 18:57:09ここでベストアンサー

SALINGER34549692009/10/12 19:02:51

コメント（4件)

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