エクセルVBAを組んでいただけますでしょうか?find関係。できる人には簡単かと思われます。


シートが2つあります。
NEWシートと、auシートです。

例・
NEWシート
C,D
7,果物>リンゴ
15,野菜>きゅうり
12,果物>みかん
・・・
(3万行以上あります。Cが数値、Dが文字列です)

auシート(セルの位置は不定)
7
12

★auシートの7と12を選択しているとします。
そこでマクロを実行すると、NEWシート内の同一番号を検索し、一致した値の1つ右のD列の枝が順番にメッセージボックスに一度に現れるようにしてほしいのです。値がない場合は「ありませんでした」NEWシート内の数字が重複することはありません。

上の例の場合には結果が、
MSGBOX
1・果物>リンゴ
2・果物>みかん

となります。auシートの選択する範囲は常に縦に連続しているものとします。
また、今回は2つのデータの選択でしたが、20個のときなどもあり、不定です。
MSGBOX内には、上の行から順に、「1・」「2・」など先頭に数字と・を加えてくださいませ。枝は極めて長くなることがあります。

お手数をおかけしますがよろしくお願いいたします。

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2011/06/11 11:37:40
  • 終了:2011/06/11 18:21:27

ベストアンサー

id:jack_sonic No.3

じゃっくそにっく回答回数123ベストアンサー獲得回数252011/06/11 16:54:09

ポイント100pt

1つのセルだけの時にも反応するようにしました。

他にご要望があればまた言ってください。

Option Explicit
Sub auMatching()
    Dim shNew As Worksheet
    Dim shAu As Worksheet
    Dim strCode As String 'マッチングコード
    Dim strValue As String 'ルックアップした値
    Dim lRow As Long '行番号
    Dim iCol As Integer '列番号
    Dim iFind As Long '順番番号
    Dim Obj As Object
    Dim strResult As String '最終結果文字列
    Dim i As Long
    Set shNew = Worksheets("NEW") ' NEW シート
    Set shAu = Worksheets("au") ' au シート
    For i = Selection(1).Row To Selection(Selection.Count).Row '選択範囲の行サーチ
        ''行単位の処理(たとえば)
        strCode = (shAu.Cells(i, Selection(Selection.Count).Column))
        If strCode <> "" Then
            iFind = iFind + 1
            Set Obj = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns)
            If Obj Is Nothing Then
                strValue = "ありませんでした"
            Else
                lRow = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns).Row
                iCol = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns).Column
                strValue = Worksheets("NEW").Cells(lRow, iCol + 1)
            End If
            '結果文字列に追加
            strResult = strResult & CStr(iFind) & "・" & strValue & vbCrLf
        End If
    Next i
    MsgBox (strResult) 'メッセージボックスに表示
End Sub
id:naranara19

迅速で完璧なご対応に心より感謝いたします。何の不安もなく、解答を待つことができました。

約束通りポイントは別途もお支払いいたします。

今後ともぜひよろしくお願いいたします。

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

2011/06/11 18:19:36

その他の回答(2件)

id:jack_sonic No.1

じゃっくそにっく回答回数123ベストアンサー獲得回数252011/06/11 14:31:17

ポイント10pt

どうぞ。標準モジュールに入れて使ってください。何か要望があれば

更に言ってください。

Option Explicit
Sub auMatching()
    Dim shNew As Worksheet
    Dim shAu As Worksheet
    Dim strCode As String 'マッチングコード
    Dim strValue As String 'ルックアップした値
    Dim lRow As Long '行番号
    Dim iCol As Integer '列番号
    Dim iFind As Long '順番番号
    Dim Obj As Object
    Dim strResult As String '最終結果文字列
    Dim i As Long
    Set shNew = Worksheets("NEW") ' NEW シート
    Set shAu = Worksheets("au") ' au シート

    If Selection.Rows.Count <> 1 Then '1列選択しか許可しない
    
        For i = Selection(1).Row To Selection(Selection.Count).Row '選択範囲の行サーチ
            ''行単位の処理(たとえば)
            strCode = (shAu.Cells(i, 3))
            If strCode <> "" Then
                iFind = iFind + 1
                Set Obj = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns)
                If Obj Is Nothing Then
                    strValue = "ありませんでした"
                Else
                    lRow = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns).Row
                    iCol = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns).Column
                    strValue = Worksheets("NEW").Cells(lRow, iCol + 1)
                End If
                '結果文字列に追加
                strResult = strResult & CStr(iFind) & "・" & strValue & vbCrLf
            End If
        Next i
        MsgBox (strResult)
    Else
        MsgBox ("auシートでは1列だけ選択してください")
    End If
End Sub
id:naranara19

ありがとうございます。どうもうまく動かないのです。

セルを4つくらい縦に選択して、実行しておりますが・・。

具体的には、auシートの

N2~N5までのセルにを下記のように4つ選択して実行すると、

222274

150858

259942

255832

メッセージボックスに白紙でOKの選択がでるだけとなっております。

コードの方は実行中となっており、マクロが終了いたしません。

新規に数の少ないシートをつくってみて、試してみたのですが、同じ状態です。

お手数ですが再度教えていただいてもよろしいでしょうか。

2011/06/11 14:58:47
id:jack_sonic No.2

じゃっくそにっく回答回数123ベストアンサー獲得回数252011/06/11 15:28:20

ポイント50pt

すみません。1行決め打ちになってしまっていたところがありました。

Option Explicit
Sub auMatching()
    Dim shNew As Worksheet
    Dim shAu As Worksheet
    Dim strCode As String 'マッチングコード
    Dim strValue As String 'ルックアップした値
    Dim lRow As Long '行番号
    Dim iCol As Integer '列番号
    Dim iFind As Long '順番番号
    Dim Obj As Object
    Dim strResult As String '最終結果文字列
    Dim i As Long
    Set shNew = Worksheets("NEW") ' NEW シート
    Set shAu = Worksheets("au") ' au シート

    If Selection.Rows.Count <> 1 Then '1列選択しか許可しない
    
        For i = Selection(1).Row To Selection(Selection.Count).Row '選択範囲の行サーチ
            ''行単位の処理(たとえば)
            strCode = (shAu.Cells(i, Selection(Selection.Count).Column))
            If strCode <> "" Then
                iFind = iFind + 1
                Set Obj = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns)
                If Obj Is Nothing Then
                    strValue = "ありませんでした"
                Else
                    lRow = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns).Row
                    iCol = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns).Column
                    strValue = Worksheets("NEW").Cells(lRow, iCol + 1)
                End If
                '結果文字列に追加
                strResult = strResult & CStr(iFind) & "・" & strValue & vbCrLf
            End If
        Next i
        MsgBox (strResult)
    Else
        MsgBox ("auシートでは1列だけ選択してください")
    End If
End Sub
id:naranara19

ありがとうございます!

うまく動きました!速度も良い感じです!

あと、最後に1つだけお願いできますでしょうか。

縦に連続すると書いてしまったのですが、1つのセルだけの時も

動くようにしていただけないでしょうか?

お手数をおかけした分、ポイントは別にもお支払いいたします。

ご丁寧な対応に感謝します。

2011/06/11 15:43:30
id:jack_sonic No.3

じゃっくそにっく回答回数123ベストアンサー獲得回数252011/06/11 16:54:09ここでベストアンサー

ポイント100pt

1つのセルだけの時にも反応するようにしました。

他にご要望があればまた言ってください。

Option Explicit
Sub auMatching()
    Dim shNew As Worksheet
    Dim shAu As Worksheet
    Dim strCode As String 'マッチングコード
    Dim strValue As String 'ルックアップした値
    Dim lRow As Long '行番号
    Dim iCol As Integer '列番号
    Dim iFind As Long '順番番号
    Dim Obj As Object
    Dim strResult As String '最終結果文字列
    Dim i As Long
    Set shNew = Worksheets("NEW") ' NEW シート
    Set shAu = Worksheets("au") ' au シート
    For i = Selection(1).Row To Selection(Selection.Count).Row '選択範囲の行サーチ
        ''行単位の処理(たとえば)
        strCode = (shAu.Cells(i, Selection(Selection.Count).Column))
        If strCode <> "" Then
            iFind = iFind + 1
            Set Obj = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns)
            If Obj Is Nothing Then
                strValue = "ありませんでした"
            Else
                lRow = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns).Row
                iCol = shNew.Cells.Find(strCode, , xlValues, xlWhole, xlByColumns).Column
                strValue = Worksheets("NEW").Cells(lRow, iCol + 1)
            End If
            '結果文字列に追加
            strResult = strResult & CStr(iFind) & "・" & strValue & vbCrLf
        End If
    Next i
    MsgBox (strResult) 'メッセージボックスに表示
End Sub
id:naranara19

迅速で完璧なご対応に心より感謝いたします。何の不安もなく、解答を待つことができました。

約束通りポイントは別途もお支払いいたします。

今後ともぜひよろしくお願いいたします。

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

2011/06/11 18:19:36

コメントはまだありません

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

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

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

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