Access VBA インポート シート指定

質問

AccessのVBA を用いて、ExcelからAccessへデータを
インポートする際、ダイアログボックスを表示させて
Excelのファイルを選択させるようにしています。

これをシート名まで指定させる事は可能でしょうか？

◆シートは枚数が固定されず、都度かわります。
◆インポートしたいシート数も都度かわります。
◆1sheet = 1 テーブルにしたいです。
◆1度の動作で、1sheetのインポートでも、複数でもかまいません。
◆できれば、ダイアログでファイルを選択した流れで
シートまで選択される方法が望ましいです。
◆Accessのテーブル名もテキストボックスで任意なものが
付けられるようにしたいです。

お知恵をお貸し下さい、何卒よろしくお願いいたします。

回答No.2

tate_san

WIN 7 Home Premium Access2010の環境でテストをしました。

シート名格納用のテーブル“T_選択シート名”（シート名・テキスト型、選択・Yes/No型、テーブル名・テキスト型）、ファイル選択用のフォーム“F_ファイル選択”（コマンドボタンを２つ＜選択、インポート＞、テキストボックスを１つ＜ファイル名＞、サブフォームを１つ＜F_選択シート名　T_選択シート名から生成＞）を作成

Microsoft Office 14.0 Object Library及びMicrosoft ActiveX Data Objects 6.0の参照設定を行う。

１．フォーム上のコマンドボタン“ファイル選択”をクリック
２．ファイル選択ダイアログボックスを表示
３．処理するエクセルふぁいえうを選択
４．DAOで選択したエクセルファイルのシート名を取得　→　Microsoft Access Clubの記事を参考
５．サブフォームにシート名を表示
６．処理するシートをサブフォーム城から選択
７．フォーム上のコマンドボタン“テーブルへインポート”をクリック
８．選択したシートをインポート
※フォームの画像を添付しましたが、見ずらかったらすみません。

Private Sub 選択_Click()
Dim FDB As FileDialog
Set FDB = Application.FileDialog(msoFileDialogFilePicker)
Dim SFL As Variant
Dim FileSelect As Variant

With FDB
.Title = "Excelファイルの選択"
.Filters.Add "Excelファイル", "*.xls; *.xlsx; *.xlsm", 1
.Filters.Add "すべてのファイル", "*.*"
.AllowMultiSelect = False
.InitialFileName = CurrentProject.Path

If .Show = -1 Then
For Each SFL In .SelectedItems
FileSelect = SFL
Next
End If
End With

Me!L_ファイル名.Visible = True: Me!ファイル名.Visible = True
Me!ファイル名 = FileSelect

DoCmd.SetWarnings False
DoCmd.RunSQL "DELETE T_選択シート名.* FROM T_選択シート名;"
DoCmd.SetWarnings True

Dim RS As New ADODB.Recordset
Dim CN As New ADODB.Connection
Set CN = CurrentProject.Connection
RS.Open "T_選択シート名", CN, adOpenKeyset, adLockOptimistic

Dim Db As DAO.Database
Dim Tbl As DAO.TableDef
Dim xlsFile As String

xlsFile = FileSelect
Set Db = OpenDatabase(xlsFile, True, True, "Excel 12.0;")

For Each Tbl In Db.TableDefs
If Right$(Tbl.Name, 1) = "$" Or Right$(Tbl.Name, 2) = "$'" Then
'シート名の最後は必ず$が付きます
RS.AddNew
RS.Fields(0).Value = Left(Tbl.Name, (Len(Tbl.Name) - 1))
RS.Update
End If
Next Tbl
RS.Close: Set RS = Nothing
CN.Close: Set CN = Nothing

Db.Close
Set Db = Nothing

Set FDB = Nothing

Me!F_選択シート名.Visible = True
Me!F_選択シート名.Requery
Me!インポート.Visible = True

End Sub

Private Sub インポート_Click()
Dim I As Integer
Dim RS As New ADODB.Recordset
Dim CN As New ADODB.Connection
Set CN = CurrentProject.Connection

RS.Open "T_選択シート名", CN, adOpenKeyset, adLockOptimistic

For I = 1 To RS.RecordCount
If RS.Fields(1).Value = True Then
DoCmd.TransferSpreadsheet , acSpreadsheetTypeExcel12, RS.Fields(2).Value, Me!ファイル名, True, RS.Fields(0).Value & "!"
End If
RS.MoveNext
Next I

RS.Close: Set RS = Nothing
CN.Close: Set CN = Nothing

End Sub

参考URL：

http://www.accessclub.jp/bbs5/0005/vba1231.html