EXCELのVBAでのCSVファイル読込みと検索
エクセルのマクロでCSVファイルを読み込み、その行の得意先サブコードをキー項目として別のCSVファイルを検索し電話番号とFAX番号を取得するという作業を下記のようなコードで作成しました。
Dim Obj As Object
Dim Path As String
Dim FName As String
Dim i As Long
Dim buf As String
Dim tmp As Variant
Dim WSH As Variant
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
'自分のPCのデスクトップをPathとして設定します。
Set WSH = CreateObject("Wscript.Shell")
Path = WSH.SpecialFolders("Desktop") & "\"
'得意先マスタ.csvをOPENする際の準備処理
'3行目のPropertiesがCSVファイルの定義(excelをOPENする時とは異なります)
Set CN = New ADODB.Connection
CN.Provider = "Microsoft.Jet.OLEDB.4.0"
CN.Properties("Extended Properties") = "Text;HDR=YES;FMT=Delimited"
CN.Open Path
'得意先サブマスタ.CSVを開きます。
Open Path & "得意先サブマスタ.csv" For Input As #1
i = 1
Do Until EOF(1)
Line Input #1, buf
tmp = Split(buf, ",")
If i = 1 Then
Else
Cells(j, 1).Value = Left(tmp(3), 4) '会社コード
Cells(j, 2).Value = Right(tmp(3), 4) '店舗コード
Cells(j, 3).Value = tmp(3) '会社@店舗
Cells(j, 4).Value = tmp(4) '得意先コード
Cells(j, 5).Value = tmp(5) '店舗名
Set RS = New ADODB.Recordset
RS.Open "SELECT * FROM 得意先マスタ.csv WHERE 得意先コード = " & tmp(4) & " ", CN
If RS.EOF Then
Cells(j, 6).Value = "???"
Cells(j, 7).Value = "???"
Else
Cells(j, 6) = RS.Fields("電話番号")
Cells(j, 7) = RS.Fields("FAX番号")
End If
End If
i = i + 1
Loop
このコードで動作確認すると途中で動作が止まってしまい応答なし状態になってしまいます。どこで止まるかは一定ではありません。CSVファイルの内容も確認したのですが、特におかしいような箇所はありませんでした。
OSはWINDOWS7、EXCELは2016です。
コード自体に修正した方がいいような箇所があればアドバイスいただきたいと思っております。宜しくお願い致します。
お礼
早速の回答、ありがとうございました。 無事に電話番号を確認出来ました。 本当にありがとうございました。