Sub ファイルを開かずに製番をFINDする()
    
    Dim appExcel As Object
    Dim sh As Worksheet
    Dim intRow As Integer
    Dim strSeib As String
    Dim rangeR As Range
    Dim intkin As Long
    Dim strCod As String
    
    Range("C5:D5").ClearContents
    Range("B7").ClearContents
    strSeib = Range("B5")
    
    Set appExcel = GetObject("E:\keiyaku.xls")
    Set rangeR = appExcel.Worksheets("商品別").Range("H6:H100").Find(strSeib)
    
    If rangeR Is Nothing Then
       appExcel.Close
       Set sppExcel = Nothing
       Set rangeR = Nothing
       MsgBox "この製番は存在しません", vbInformation, "製番変更"
       
       Exit Sub
    End If
       
    If strSeib <> rangeR Then
       appExcel.Close
       Set sppExcel = Nothing
       Set rangeR = Nothing
       MsgBox "この製番は存在しません", vbInformation, "製番変更"

       Exit Sub
    End If
       
    intRow = rangeR.Row
    intkin = appExcel.Worksheets("商品別").Range("G" & intRow)
    strCod = appExcel.Worksheets("商品別").Range("B" & intRow)
    
    Range("C5").Value = intkin
    Range("D5").Value = intRow
    Range("B7").Value = strCod '機種コード
    
    appExcel.Close
    Set sppExcel = Nothing
    Set rangeR = Nothing
       
End Sub