人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセル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・」など先頭に数字と・を加えてくださいませ。枝は極めて長くなることがあります。

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

●質問者: naranara19
●カテゴリ:コンピュータ 科学・統計資料
✍キーワード:12 AU VBA きゅうり つの
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● じゃっくそにっく
●10ポイント

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

更に言ってください。

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の選択がでるだけとなっております。

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

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

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


2 ● じゃっくそにっく
●50ポイント

すみません。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つのセルだけの時も

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

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

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


3 ● じゃっくそにっく
●100ポイント ベストアンサー

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
◎質問者からの返答

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

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

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ