ファイル選択ダイアログを開いて、選択したExcelファイルの先頭シートを読み込み、番号が一致するデータの配送日を本日日付で消し込む処理（楽天販売DB.mdb）
ダイアログを表示する際には、事前にMicrosoft Office x.x bject Libraryに参照設定しておく。
ダイアログ表示と、Excelの先頭シート名を取得するときに、苦労。
参考リンク：
必要な列と行だけEXCELからインポートしたい –Access Club 超初心者 FORUM–
[code]
Private Sub cmd楽天伝票消込_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim fi As Long, foi As Long, fno As String
Dim wsName As String
Dim intRet As Integer ‘ダイアログ用変数
Dim ImPass As String ‘フルパスの値
With Application.FileDialog(msoFileDialogOpen)
‘ダイアログのタイトルを設定
.Title = "ファイルを開くダイアログ"
.Filters.Clear
.Filters.Add "Microsoft Office Excelファイル", "*.xls,*.csv"
.FilterIndex = 1
.AllowMultiSelect = False ‘複数ファイル選択を許可しない
.InitialFileName = "\\FileServer\share\ ‘初期パスを設定
intRet = .Show ‘ダイアログを表示
If intRet <> 0 Then
ImPass = Trim(.SelectedItems.Item(1))
Else
ImPass = ""
MsgBox "ファイルが選択されませんでした"
Exit Sub
End If
End With
‘ *** Excelのシート名を取得する処理
‘ ms access – Read Excel file sheet names – Stack Overflow
‘ https://stackoverflow.com/questions/18412697/read-excel-file-sheet-names
Dim objExc As Object ‘ late
Dim objWbk As Object ‘ late
Dim objWsh As Object ‘ late
‘Set objExc = New Excel.Application ‘ early
Set objExc = CreateObject("Excel.Application") ‘ late
Set objWbk = objExc.Workbooks.Open(ImPass)
For Each objWsh In objWbk.Worksheets
wsName = objWsh.Name
Next
Set objWsh = Nothing
objWbk.Close
Set objWbk = Nothing
objExc.Quit
Set objExc = Nothing
‘***
Set dbs = Application.CurrentData
Set db = CurrentDb()
mySQL = "SELECT お客様管理番号 FROM [" & wsName & "$] IN ‘" & ImPass & "’ ‘Excel 8.0;’;"
Set rs = db.OpenRecordset(mySQL, dbOpenDynaset, dbSeeChanges)
If rs.EOF = False Then rs.MoveLast
ProgBarCnt = rs.RecordCount
If rs.EOF = True Then
MsgBox "楽天テーブルにデータはありませんでした"
Exit Sub
Else
rs.MoveFirst
Do Until rs.EOF
strSQL = "SELECT ID FROM Zaiko楽天販売TBL WHERE 受注番号 = ‘" & rs!お客様管理番号 & "’;"
Set rst = db.OpenRecordset(strSQL, dbOpenDynaset, dbSeeChanges)
If rst.EOF Then
Else
CurrentDb.Execute "UPDATE zaiko楽天販売TBL SET 配送日 = #" & Date & "# WHERE [受注番号] = ‘" & rs!お客様管理番号 & "’;"
fi = fi + 1
End If
rst.Close
rs.MoveNext
Loop
End If
MsgBox "楽天" & fi & "件のレコードを更新しました。"
rs.Close: Set rs = Nothing
db.Close: Set db = Nothing
Exit_cmd楽天伝票消込_Click:
Exit Sub
Err_cmd楽天伝票消込_Click:
MsgBox Err.Description
End Sub
[/code]
