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

質問

• VBAをほとんど知らない人間がネットで調べながら組んでみたものの行き詰ってしまった検索に関する質問です
• aシートのB列に4～6桁のID番号を、日によって異なる数を入力してコマンドボタンを押すと別ファイルであるbのシートからリンク先を検出してaシートの入力されたIDと同じ行の指定列へ貼り付けたいのです
• 質問内容には、bシートのID番号を検索する際の問題や要望が含まれています。具体的には、ID番号にアルファベットがついていたり、検索対象の列にID番号以外の文字がついていたりすることが難点です

回答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列(検索したリンク先を貼り付けたい列)に結果が貼り付けられませんでした

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