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

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

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

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

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

No.2 回答者： tate_san 回答日時： 2011/10/09 20:59

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

No.1 回答者： imogasi 回答日時： 2011/10/09 11:12

数日前に同様のエクセルからアクセスへVBAでインポートする質問の回答のとき書いたのだが、

oCmd.TransferSpreadsheet acImport
を使う限りでは,シートは個別に指定しなければならず、１シート１回ずつの実行になると思う。
出来ることは、これをVBAで繰り回すプログラムを作ることだけではないかな。
（エクセルVBAでシートをよみ、ADOなどでアクセスのテーブルにレコードを書き込んでいく方法はあるが、本回答はそれは目指してない）
・ファイル指定
＞「ダイアログボックスを表示させてExcelのファイル（X)を選択させるようにしています、であればその点は解決済みと思うので
・シート指定
あとはシート名を何かに表示させて、シートを１つ選択させて（Y）、両者からDocmdの文字列にX,Yを組み込めば仕舞いでしょう。
ーー
例　全般的に見て主要なテーマは
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "01化", "01化.xls", True, "Sheet1!A1:D3"
ーー
２つのことがしたいのだと思う
（１）（アクセスにインポートしたい）エクセルファイル（ブック）を１つ指定
沢山のブックを一遍に指定していくようなのは、さらに難しくなると思うので除外
（２）そのファイルの中のシートを１つ指定
こちらは複数同時指定は出来ない模様。
これらを出来れば対話形式（ダイアロウグ）で選択したいということかな。
ーーー
しかし、結構下記は難物であるようだ。
（１）アクセスではファイル選択のダイアロウグは（APIを使わないと出来ない、APIの使用はVBAを外れる。
WEBには例が載っているが）使えないようだ。
質問者は出来ているような口ぶりだが、この部分はどのようにしたのかな。
（２）シート選択のダイアロウグが（これはもちろんエクセルVBAの世界でだが）が良いものが無い。
これもWEBに回答として上がっている例があるが、難しいので使用を避けた。PopUpなどの例があるが、簡単ではない。
それでInputBoxのコメントにシート名をだし、その中の番号を入力するで逃げた。
それで、エクセルとアクセスを行き来する、すっきりしないものになっているが一応私の試行例を挙げておく。
改良してください。
ーーー
Access（エクセルではない）のモジュールに
Sub Sample4()
Dim sn(30)
Dim ws As Object
Dim xlsFileName As String
Set xls = CreateObject("Excel.Application")
xlsFileName = xls.GetOpenFilename("Microsoft Excelブック,*.xls")
If xlsFileName <> "False" Then
fn = Split(xlsFileName, "\")
fns = fn(UBound(fn)) 'ファイル名の部分を摘出
MsgBox fns
Else
MsgBox "キャンセルされました"
End If
'--
Set bk = xls.workbooks.Open(xlsFileName)
'----シート選択
i = 1
For Each ws In bk.Worksheets
sn(i) = ws.name
s = s & i & " " & ws.name & vbCr
i = i + 1
Next
X = InputBox(s, "シート選択　番号指定")
MsgBox sn(X) & " を選択しました"
sns = sn(X)
'--
bk.Close
xls.Quit
Set xls = Nothing
'-----エクセルは脱出してアクセスで実行
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "01化", fns, True, sns & "!A1:D4"
End Sub
この例では１シートのコードなので、まず１例でテストして出来るかどうか納得してください。
その後、「多数または同一のブック」の他シートについて連続してやる場合は、上記のコード全体をループの中において、
DoCmd.のテーブル名の01化　　に当たるアクセスの（エクセルの１シートに対応する）テーブル名を都度使用者から、変数に受け取るようなコードに変えて、（最低ではInputBoxで聞いて、応答を受ける）、その変数で、テーブル名をセットするに変えてください。
各シートのデータ範囲は最大の範囲を指定して、うまく行かないかやってみてください。（毎回範囲を指定するとなるとさらに複雑になる。エクセル側で、Application.Inputboxのタイプ8利用など。）