シートが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つのセルだけの時にも反応するようにしました。
他にご要望があればまた言ってください。
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
どうぞ。標準モジュールに入れて使ってください。何か要望があれば
更に言ってください。
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
ありがとうございます。どうもうまく動かないのです。
セルを4つくらい縦に選択して、実行しておりますが・・。
具体的には、auシートの
N2~N5までのセルにを下記のように4つ選択して実行すると、
222274
150858
259942
255832
メッセージボックスに白紙でOKの選択がでるだけとなっております。
コードの方は実行中となっており、マクロが終了いたしません。
新規に数の少ないシートをつくってみて、試してみたのですが、同じ状態です。
お手数ですが再度教えていただいてもよろしいでしょうか。
すみません。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
ありがとうございます!
うまく動きました!速度も良い感じです!
あと、最後に1つだけお願いできますでしょうか。
縦に連続すると書いてしまったのですが、1つのセルだけの時も
動くようにしていただけないでしょうか?
お手数をおかけした分、ポイントは別にもお支払いいたします。
ご丁寧な対応に感謝します。
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
迅速で完璧なご対応に心より感謝いたします。何の不安もなく、解答を待つことができました。
約束通りポイントは別途もお支払いいたします。
今後ともぜひよろしくお願いいたします。
本当にありがとうございました。
迅速で完璧なご対応に心より感謝いたします。何の不安もなく、解答を待つことができました。
約束通りポイントは別途もお支払いいたします。
今後ともぜひよろしくお願いいたします。
本当にありがとうございました。