VBA ソートに関する初心者の質問

質問

VBAをほとんど知らない人間がネットで調べながら組んでみたものの
行き詰ってしまった検索に関する質問です

現状：
・aシートは、「ID(4～6桁)毎の名前がついたフォルダ(7000個程度)が格納されているデータベース」への「各ID毎のリンク先を表示させる為のシート」として使用
・bシートが検索対象の一覧表になっており(2万行程)、全IDのデータが格納されているリンク先が記載されている

問題：
・bシートのID番号を検索する為の列は、ID番号の他にアルファベットがついている
　例：ID→B1001・10101・123123等で、数字が4桁の場合は先頭に固定文字が一つ付く(B)
・検索対象であるbシートの対象列にはID番号以外にも文字がついている
例：B1234_ABC-TOUKYOUTONAKANOKU
　　12345_DEF-TOUKYOUTOTOSHIMAKU
　　912345_FED-TOUKYOUTONAKANOKU

やりたい事：
aシートのB列に4～6桁のID番号を、日によって異なる数を入力してコマンドボタンを押すと別ファイルであるbのシート(オートフィルタがついた一覧表)からリンク先を検出してaシートの　入力されたIDと同じ行の指定列へ貼り付けたいのです。

Sub DATA_IMPORT_macro()
Dim ID As Integer, IDなし As Integer, COUNT1 As Integer
Dim LAST_LINE As String, ID_NAME As String, ID_RNAME As String, FILE_NAME As String, FOLDER_NAME As String, LINK_NAMEA As String, LINK_NAMEB As String, LINK_NAMEC As String, LINK_FW As String, LINK_FL As String, TEST As String, LINK_LK As String

LINK_FW = Range("F4")
LINK_FL = Range("F5")
LINK_LK = Range("F6")

If Not Range("ID入力セル") = "" Then
ID = Range("ID入力セル").Value
End If

Workbooks.Open Filename:="ファイル名.xls", ReadOnly:=True
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
　　　　Else: ActiveSheet.Select
End If

　　　'編集用にbシートをコピー
Worksheets("シート名").Copy After:=Worksheets("最後のシート名")

(1) Set IDなし = Range("ID行:ID行").Find(what:=ID, lookat:=xlPart, SearchOrder:=xlByRows).Select
If Not NO_ID Is Nothing Then
If

FoundCell.Select
End If

(2) Cells(Rows.count, 6).End(xlUp).Copy
last_row = ActiveCell.Row
　　Selection.Workbooks("aシートのあるブック名").Worksheets("aシート名").Range("I13").past　'I13=リンク先の貼り付け用セル

(1)と(2)でつまづいています・・・
(1)：入力されたIDを一覧表で検索する為に、Replaceで「B」を消して完全一致でFindすればいいのかな・・・とおもって色んなサイトで構文をコピペして編集したんですがうまくいきません

(2)一覧表は日付で更新されていて、最新のデータが一番下に表示される為一番下を検出してそのリンク先をコピペさせたかったのですが・・・うまくいきません

どうかご教授おねがいします＞＜

回答No.3

_Kyle · ベストアンサー

#1-2です。
こちらこそ何度もスミマセン。

ん～、「何事もなく終了」しちゃいましたか。

Checkが全部OKだったということは
範囲と値は取れてるんですね。

であれば、
●「ヒットしてない」（検索がうまくいってない）
●「コピペできてない」（貼り付けがうまくいってない）
のどちらかということになりますが……
--------------------------
◆確認

bシートの検索ID列にあるIDは
　例：
　12345_DEF-TOUKYOUTOTOSHIMAKU
のように
　[aシートの検索ID]＋[半角のアンダースコア(_)]＋[文字列]
のカタチになってるんですよね？

提示したコードは、
【[bシートの検索ID](アタマに[B]がついていれば取ったもの)】
のうちから
【[aシートの入力ID]の後ろに[半角のアンダースコア]と[任意の文字列]をつけたもの】
を探します。
--------------------------
◆テストコードの[■検索・コピペ]部分を
次のように差し替えて、

【aシート２～３行,bシート10行程度のダミーデータで】
テストしみてください。
（実データでやると終わらないので）

うまくいくようでしたら
Application.ScreenUpdating = True
と
MsgBox
を外してそのままお使いください。

※中断する場合は
　ESCキーではなくCtrl＋Breakを使ってください。

'-----↓サシカエ↓-------------------------------
　'■検索・コピペ

　'うまくいったら削除
　Application.ScreenUpdating = True

　'aシートの入力IDを1番目から最後まで調べる
　For i = 1 To ipCnt

　　'結果列にとりあえず「該当なし」と入れておく
　　rtRng.Cells(i, 1).Value = "該当なし"

　　'aシートのi番目の入力IDの後ろに"_*"を付ける
　　'　"99999_*"のカタチにする
　　'　"*"は[任意の文字列]を意味する[ワイルドカード]です。
　　tpStr = ipAry(i) & "_*"

　　'bシートの検索IDを最後から1番目までチェック
　　For j = idCnt To 1 Step -1

　　　MsgBox _
　　　　"較べてみるよ" & vbCrLf & vbCrLf & _
　　　　"aシート入力ID：　" & tpStr & vbCrLf & _
　　　　"bシート検索ID：　" & idAry(j)

　　　'もし、bシートのj番目の検索IDが
　　　'[i番目の入力ID]_[ABCDEFG…]というカタチなら
　　　If idAry(j) Like tpStr Then

　　　　MsgBox "ヒットしたよ！　＼(^o^)／"

　　　　'bシートリンク列の、
　　　　'検索IDと同じ行のセル(i番目のセル)をコピーして
　　　　'aシート結果列の、
　　　　'入力IDと同じ行のセル(j番目のセル)に貼り付ける
　　　　lkRng.Cells(j, 1).Copy _
　　　　　Destination:=rtRng.Cells(i, 1)

　　　　MsgBox "コピーしたよ！"

　　　　'ヒットしたので残りの検索IDは飛ばして次の入力IDへ
　　　　Exit For
　　　End If

　　'次の検索IDを調べる
　　Next j

　'次の入力IDを調べる
　Next i
'-----↑サシカエ↑-------------------------------

動画付けてみました。
音は出ませんからどうぞご安心を。

お礼

できました！ありがとうございます！！
この先もまだ続きますが、大きな一歩が踏み出せました
無い様に心がけますが、次がありましたらよろしくお願いします。

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

回答No.2

_Kyle

#1です。

最初のコードは、一応動作確認はしたんですが
いろいろ大雑把過ぎたようです。^^;;;;;;;;

テスト用のコードを挙げますので
Check00～Check10の結果をお知らせください。

例
　Check01：OK
　Check02：OK
　Check03：メッセージは出るけど値がおかしい。
　Check04：止まった。エラーコードXXX。「●●」の部分が黄色になる。

↑こんな感じで。

状況が判らないので、冗談みたいなコードになってますが
エラーになりそうな部分をちょこちょこ修正しています。
もし、テスト用コードでうまくいくようでしたら
Msgboxの部分を削ってそのままお使いください。

それから
途中で終了すると自動再計算が切りっぱなしになってしまいます。
オマケマクロ「自動再計算ON」で元に戻してください。

'-----↓ココカラ↓-------------------------------
Sub DATA_IMPORT_macro()

　'■設定
　'-----------------------↓ココだけ変更↓-------
　Const myBkn As String = "aシートのあるブック名.xls"
　Const myShn As String = "aシート名" '←シート名の空白等に注意
　Const ipRga As String = "B3:B999"　 '←aシートの入力範囲
　Const rtRga As String = "I3:I999"　 '←aシートの結果範囲

　Const dtDir As String = "C:\Documents and Settings\b～ブックのあるフォルダ"
　Const dtBkn As String = "bシートのあるブック名.xls"
　Const dtShn As String = "bシート名" '←シート名の全半角に注意
　Const idRga As String = "C4:C39999" '←bシートのID範囲
　Const lkRga As String = "F4:F39999" '←bシートのリンク範囲
　'-----------------------↑ココだけ変更↑-------

　　MsgBox Title:="◆Check00", _
　　　Prompt:="bシートのあるブック名(フルパス) ： " _
　　　& dtDir & "\" & dtBkn

　'■宣言
　Dim myBok　 As Workbook
　Dim dtBok　 As Workbook
　Dim mySht　 As Worksheet
　Dim dtSht　 As Worksheet
　Dim ipRng　 As Range
　Dim rtRng　 As Range
　Dim idRng　 As Range
　Dim lkRng　 As Range
　Dim ipAry() As String
　Dim idAry() As String
　Dim ipCnt　 As Long
　Dim idCnt　 As Long
　Dim tpAry　 As Variant
　Dim tpItm　 As Variant
　Dim tpStr　 As String
　Dim ckFlg　 As Boolean
　Dim i　　　 As Long
　Dim j　　　 As Long

　'■お約束
　Application.ScreenUpdating = False
　Application.Calculation = xlCalculationManual

　'■オブジェクト格納
　Set myBok = Workbooks(myBkn)

　　MsgBox Title:="◆Check01", _
　　　Prompt:="aシートのあるブック名 ： " & myBok.Name

　Set mySht = myBok.Worksheets(myShn)

　　MsgBox Title:="◆Check02", _
　　　Prompt:="aシート名 ： " & mySht.Name

　Set ipRng = mySht.Range(ipRga)

　　MsgBox Title:="◆Check03", _
　　　Prompt:="aシートの入力範囲 ： " & ipRng.Address

　Set rtRng = mySht.Range(rtRga)

　　MsgBox Title:="◆Check04", _
　　　Prompt:="aシートの結果範囲 ： " & rtRng.Address

　ckFlg = False
　For Each tpItm In Workbooks
　　If tpItm.Name = dtBkn Then ckFlg = True
　Next tpItm
　If ckFlg Then
　　Set dtBok = Workbooks(dtBkn)
　Else
　　Set dtBok = Workbooks.Open( _
　　Filename:=dtDir & "\" & dtBkn, ReadOnly:=True)
　End If

　　MsgBox Title:="◆Check05", _
　　　Prompt:="bシートのあるブック名 ： " & dtBok.Name

　Set dtSht = dtBok.Worksheets(dtShn)

　　MsgBox Title:="◆Check06", _
　　　Prompt:="bシート名 ： " & dtSht.Name

　Set idRng = dtSht.Range(idRga)

　　MsgBox Title:="◆Check07", _
　　　Prompt:="bシートのID範囲 ： " & idRng.Address

　Set lkRng = dtSht.Range(lkRga)

　　MsgBox Title:="◆Check08", _
　　　Prompt:="bシートのリンク範囲 ： " & lkRng.Address

　'■データ格納(aシート)
　ReDim ipAry(1 To ipRng.Rows.Count)
　ipCnt = 0
　For Each tpItm In ipRng
　　If tpItm.Value = "" Then Exit For
　　ipCnt = ipCnt + 1
　　ipAry(ipCnt) = tpItm.Text
　Next tpItm
　ReDim Preserve ipAry(1 To ipCnt)

　　MsgBox Title:="◆Check09", _
　　　Prompt:="入力IDの数　：　" & ipCnt & vbCrLf & _
　　　　　　　"最初のID　：　" & ipAry(1) & vbCrLf & _
　　　　　　　"最後のID　：　" & ipAry(ipCnt)

　'■データ格納(bシート)
　ReDim idAry(1 To idRng.Rows.Count)
　 idCnt = 0
　 tpAry = idRng.Value
　 For Each tpItm In tpAry
　　 If tpItm = "" Then Exit For
　　 idCnt = idCnt + 1
　　 If Left(tpItm, 1) = "B" Then
　　　 tpItm = Mid(tpItm, 2)
　　 End If
　　 idAry(idCnt) = tpItm
　 Next tpItm
　 ReDim Preserve idAry(1 To idCnt)

　　MsgBox Title:="◆Check10", _
　　　Prompt:="IDの数　：　" & idCnt & vbCrLf & _
　　　　　　　"最初のID　：　" & idAry(1) & vbCrLf & _
　　　　　　　"最後のID　：　" & idAry(idCnt)

　'■検索・コピペ
　For i = 1 To ipCnt
　　tpStr = ipAry(i) & "_*"
　　For j = idCnt To 1 Step -1
　　　If idAry(j) Like tpStr Then
　　　　lkRng.Cells(j, 1).Copy _
　　　　　Destination:=rtRng.Cells(i, 1)
　　　　Exit For
　　　End If
　　Next j
　Next i

　'■終了
　If Not ckFlg Then dtBok.Close
　Application.Calculation = xlCalculationAutomatic

End Sub

'■オマケ
Sub 自動再計算ON()
　Application.Calculation = xlCalculationAutomatic
End Sub
'-----↑ココマデ↑-------------------------------

お礼

何度もありがとうございます。

結果についてはCheck01~10まで全てOKでした
ただ、そのまま何事もなく終了してしまいました

Check10のmsgboxには欲しい検索結果が反映されていたのですが
aシートのF列(検索したリンク先を貼り付けたい列)に結果が貼り付けられませんでした

検索・コピペ部分を読んでいるのですがどうにも理解が追いつかず・・・すいません><;

回答No.1

_Kyle

既に自己解決されたかもしれませんが…。

※ワークシート機能の[検索]ではなく、
　VBA上でデータを照合します。

※aシート入力列・bシートID列とも、
　途中に空白が無い前提です。

※bシートは、開いて読んで閉じるだけで、
　いじらないのでコピーしていません。

※bシートのID列を読む際、アタマに"B"がついていれば、
　削ってから配列に格納します。

※bシートのID列を【下から】チェックして、
　最初にヒットした行のリンクをコピーします。

※コードでセル範囲を指定している部分は
　【見出し行を含めずに】指定してください。

aシート：50件
bシート：3万件
について手元の環境でテストしたところ、
大量のリンクが貼られた[bシートのあるブック名.xls]を開く処理に10数秒を要するものの
検索・コピペ自体は0.5秒程度で終了します。

仕様が動くかもと思って丁寧に書きましたが前処理が大げさですね。
素人の手すさびなので
「お手本」にはしない方がよいかもしれません。(^^;;;;;;;;

Excel2003で動作確認。

もしうまくいかないようでしたら
　・エラーの内容とエラーになる場所
　・Excelのバージョン
を補足していただければ戻ってきます。

'-----↓ココカラ↓-------------------------------
Sub DATA_IMPORT_macro()

　'■宣言
　Dim myBok　 As Workbook　 'aシートのあるブック
　Dim dtBok　 As Workbook　 'bシートのあるブック
　Dim mySht　 As Worksheet　'aシート
　Dim dtSht　 As Worksheet　'bシート
　Dim ipRng　 As Range　　　'aシートの入力列
　Dim rtRng　 As Range　　　'aシートの結果列
　Dim idRng　 As Range　　　'bシートのID列
　Dim lkRng　 As Range　　　'bシートのリンク列
　Dim ipAry() As String　　 'aシートの入力ID
　Dim idAry() As String　　 'bシートのIDデータ
　Dim ipCnt　 As Long　　　 'aシートの入力ID数
　Dim idCnt　 As Long　　　 'bシートのID数
　Dim tpAry　 As Variant
　Dim tpItm　 As Variant
　Dim tpStr　 As String
　Dim i　　　 As Long
　Dim j　　　 As Long

　'■お約束
　Application.ScreenUpdating = False
　Application.Calculation = xlCalculationManual

　'■オブジェクト格納
　Set myBok = Workbooks("aシートのあるブック名.xls")
　Set mySht = myBok.Worksheets("aシート名")
　Set ipRng = mySht.Range("B3:B999")
　Set rtRng = mySht.Range("I3:I999")

　Set dtBok = Workbooks.Open( _
　　Filename:="bシートのあるブック名.xls", _
　　ReadOnly:=True)
　Set dtSht = dtBok.Worksheets("bシート名")
　Set idRng = dtSht.Range("C4:C39999")
　Set lkRng = dtSht.Range("F4:F39999")

　'■データ格納(aシート)
　ReDim ipAry(1 To ipRng.Rows.Count)
　ipCnt = 0
　tpAry = ipRng.Value
　For Each tpItm In tpAry
　　If tpItm = "" Then Exit For
　　ipCnt = ipCnt + 1
　　ipAry(ipCnt) = tpItm
　Next tpItm
　ReDim Preserve ipAry(1 To ipCnt)

　'■データ格納(bシート)
　ReDim idAry(1 To idRng.Rows.Count)
　idCnt = 0
　tpAry = idRng.Value
　For Each tpItm In tpAry
　　If tpItm = "" Then Exit For
　　idCnt = idCnt + 1
　　If Left(tpItm, 1) = "B" Then
　　　tpItm = Mid(tpItm, 2)
　　End If
　　idAry(idCnt) = tpItm
　Next tpItm
　ReDim Preserve idAry(1 To idCnt)

　'■検索・コピペ
　For i = 1 To ipCnt
　　tpStr = ipAry(i) & "_*"
　　For j = idCnt To 1 Step -1　　　　'下から見る
　　　If idAry(j) Like tpStr Then
　　　　lkRng.Cells(j, 1).Copy _
　　　　　Destination:=rtRng.Cells(i, 1)
　　　　Exit For
　　　End If
　　Next j
　Next i

　'■終了
　dtBok.Close
　Application.Calculation = xlCalculationAutomatic

End Sub
'-----↑ココマデ↑-------------------------------

以上ご参考まで。長乱コード陳謝。

お礼

どうもありがとうございます、あれから遅々として進まず
悩み続けていましたので大変助かります。

記載して頂いたプログラムを転記してファイル名等を変更し
マクロを走らせて見ているのですが、走らせるたびにエラーの内容が変わっているみたいでした
ファイル名相違等のケアレスな部分等も意識して修正しているのですが
なかなか原因の特定ができていません

また、書いて頂いている内容もきちんと理解できないものが多い為
ネットで調べながらやってますが会社でしかできない為
亀の歩みではありますがまた質問できる状態になりましたらさせて頂きたいと思います

ちなみにExcelは2003です。