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

Question

リセール京都買取

74

74もっと見る

160pt

コンピュータ科学・統計資料

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

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

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

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

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

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

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

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

回答の条件

1人3回まで

登録：2011/06/11 11:37:40
終了：2011/06/11 18:21:27

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

No.1

じゃっくそにっく124252011/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 '１列選択しか許可しない
    
        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シートでは１列だけ選択してください")
    End If
End Sub

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

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

具体的には、auシートの

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

222274

150858

259942

255832

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

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

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

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

2011/06/11 14:58:47

No.2

じゃっくそにっく124252011/06/11 15:28:20

50pt

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

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 '１列選択しか許可しない
    
        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シートでは１列だけ選択してください")
    End If
End Sub

ありがとうございます！

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

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

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

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

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

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

2011/06/11 15:43:30

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

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

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

リクエスト送信済

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

じゃっくそにっく · Accepted Answer · 2011-06-11T16:54:09+09:00

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

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

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

じゃっくそにっく · Accepted Answer · 2011-06-11T16:54:09+09:00

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

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

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

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

ベストアンサー

じゃっくそにっく124252011/06/11 16:54:09

その他の回答（2件）

じゃっくそにっく124252011/06/11 14:31:17

じゃっくそにっく124252011/06/11 15:28:20

じゃっくそにっく124252011/06/11 16:54:09ここでベストアンサー

コメント（0件)

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