アクセス VBA サブフォルダからインポート

質問

アクセス・エクセル2010を使用しています。
以下の作業を実行したいと考えていますが、初心者につき、ご教示ください！

1．ダイアログを表示させ、フォルダを指定したい：トップパス設定
2．1で指定したトップパス内（サブフォルダを含む）にある
　一定のネーミングファイルを範囲を指定してインポート（マージ）したい

動作条件）
a．トップパス：D:\test　←ダイアログで指定したい（可能であれば・・次回の動作時に覚えさせておきたい）
b．インポートファイルの名称：*_3年目.xls（語尾に「_3年目」と付くエクセル）　←フォームのテキストボックスで設定したい
c．インポート範囲：B7:Z56　←変動するので、フォームのテキストボックスで設定したい

現在、同じパス内にあるエクセルファイルを指定した範囲でテーブルにインポートする
というところまでは、ご親切な方にご教示いただき、以下にてうまく動いています。

初心者のため、どこをどう変更・設定すると
上記のような動きにできるのかがわかっておりませんため、
ご教示いただけないでしょうか。

※[frm]![txt_範囲]：範囲指定をするフォームのテキストボックス
　仮テーブル：取り込み時に作成するマージ用テーブル

Dim f As Object
Dim b As Object
Dim c As Object
Dim d As Object
Dim t As Variant
Dim e As Object
Dim p As String
Dim i As Long
Dim sSql As String
Dim x As String

Set e = CreateObject("Excel.Application")
t = e.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If t = False Then Exit Sub

x = Forms![frm]![txt_範囲]

Set f = CreateObject("Scripting.FileSystemObject")
p = f.GetParentFolderName(t)
Set d = f.GetFolder(p)
Set b = d.Files

On Error Resume Next
sSql = "DROP TABLE 仮テーブル "
CurrentProject.Connection.Execute CommandText:=sSql
sSql = "DROP TABLE 一時テーブル "
CurrentProject.Connection.Execute CommandText:=sSql
On Error GoTo 0
For Each c In b
If LCase(f.GetExtensionName(c)) Like "xls*" Then
If i = 0 Then
DoCmd.TransferSpreadsheet acImport, , "仮テーブル", c, True, x
sSql = "ALTER TABLE 仮テーブル ADD COLUMN ファイル名 VarChar(50);"
CurrentProject.Connection.Execute CommandText:=sSql
sSql = "UPDATE 仮テーブル SET ファイル名='" & f.GetFileName(c) & "';"
CurrentProject.Connection.Execute CommandText:=sSql
i = i + 1
Else
On Error Resume Next
sSql = "DROP TABLE 一時テーブル "
CurrentProject.Connection.Execute CommandText:=sSql
On Error GoTo 0
DoCmd.TransferSpreadsheet acImport, , "一時テーブル", c, True, x
sSql = "ALTER TABLE 一時テーブル ADD COLUMN ファイル名 VarChar(50);"
CurrentProject.Connection.Execute CommandText:=sSql
sSql = "UPDATE 一時テーブル SET ファイル名='" & f.GetFileName(c) & "';"
CurrentProject.Connection.Execute CommandText:=sSql
sSql = "INSERT INTO 仮テーブル SELECT * FROM 一時テーブル"
CurrentProject.Connection.Execute CommandText:=sSql
i = i + 1
End If
End If
Next

On Error Resume Next
sSql = "DROP TABLE 一時テーブル "
CurrentProject.Connection.Execute CommandText:=sSql
On Error GoTo 0
e.Quit
Set e = Nothing

MsgBox "データがインポートされました。"

End Sub

尚、せっかく教えていただいたコードではありますが、
上記コードを用いては思った動作にならないのであれば、
新しい手法で教えていただくんでも構いません。
是非、よろしくお願いします！！

回答No.1

ushi2015 · ベストアンサー

こんにちは
参照設定「Microsoft Scripting Runtime」で、
モジュールの先頭から、
Option Compare Database
Option Explicit
Dim j As Long
Dim x As String
Dim sSql As String
Sub Shori_0()
　　Dim f As Object
　　Dim b As Object
　　Dim c As Object
　　Dim d As Object
　　Dim t As Variant
　　Dim e As Object
　　Dim p As String
　　Dim i As Long

　　Set e = CreateObject("Excel.Application")
　　With e.FileDialog(4)
　　　　If .Show = True Then
　　　　　　t = .SelectedItems(1)
　　　　Else
　　　　　　e.Quit
　　　　　　Set e = Nothing
　　　　　　Exit Sub
　　　　End If
　　End With
　　e.Quit
　　Set e = Nothing

　　x = Forms![frm]![txt_範囲]

　　Set f = CreateObject("Scripting.FileSystemObject")

　　On Error Resume Next
　　sSql = "DROP TABLE テストテーブル "
　　CurrentProject.Connection.Execute CommandText:=sSql
　　sSql = "DROP TABLE 一時テーブル "
　　CurrentProject.Connection.Execute CommandText:=sSql
　　On Error GoTo 0

　　Call Shori_1(f.GetFolder(t), i)

　　On Error Resume Next
　　sSql = "DROP TABLE 一時テーブル "
　　CurrentProject.Connection.Execute CommandText:=sSql
　　On Error GoTo 0
End Sub

Sub Shori_1(ByVal objFolder As Folder, ByRef j As Long)
　　Dim u As Folder
　　Dim w As File
　　For Each u In objFolder.SubFolders
　　　　Call Shori_1(u, j)
　　Next
　　For Each w In objFolder.Files
　　　　With w
　　　　　　Call Shori_2(.Path)
　　　　End With
　　Next
　　Set u = Nothing
　　Set w = Nothing
End Sub

Sub Shori_2(c As String)
　　If c Like "*_3年目.xls*" Then
　　　　If j = 0 Then
　　　　　　DoCmd.TransferSpreadsheet acImport, , "テストテーブル", c, True, x
　　　　　　sSql = "ALTER TABLE テストテーブル ADD COLUMN ファイル名 VarChar(250);"
　　　　　　CurrentProject.Connection.Execute CommandText:=sSql
　　　　　　sSql = "UPDATE テストテーブル SET ファイル名='" & c & "';"
　　　　　　CurrentProject.Connection.Execute CommandText:=sSql
　　　　　　j = j + 1
　　　　Else
　　　　　　On Error Resume Next
　　　　　　sSql = "DROP TABLE 一時テーブル "
　　　　　　CurrentProject.Connection.Execute CommandText:=sSql
　　　　　　On Error GoTo 0
　　　　　　DoCmd.TransferSpreadsheet acImport, , "一時テーブル", c, True, x
　　　　　　sSql = "ALTER TABLE 一時テーブル ADD COLUMN ファイル名 VarChar(250);"
　　　　　　CurrentProject.Connection.Execute CommandText:=sSql
　　　　　　sSql = "UPDATE 一時テーブル SET ファイル名='" & c & "';"
　　　　　　CurrentProject.Connection.Execute CommandText:=sSql
　　　　　　sSql = "INSERT INTO テストテーブル SELECT * FROM 一時テーブル"
　　　　　　CurrentProject.Connection.Execute CommandText:=sSql
　　　　　　j = j + 1
　　　　End If
　　End If
End Sub

お礼

今回も本当に助かりました！
また何かありましたら、ご教示のほど よろしくお願い致します。

補足

参照設定しましたが、
Option Compare Database　部分で
「プロジーシャ内では無効です。」のコンパイルエラーが出てしまいます。

今回もご面倒おかけしますが、教えていただけますでしょうか。
よろしくお願いします！

回答No.3

ushi2015

こんにちは
こちらでテストしている限りでは動いています。
どのコードでエラーになっていますか？

補足

ご連絡遅くなりました。
ご質問しておりましたコンパイルエラーですが、（別件で）PCを再起動したところ、エラーが出なくなりました。
どういうことなのかは不明ですが、大丈夫そうです。
お騒がせして申し訳ありませんでした。

回答No.2

ushi2015

こんにちは
モジュールの先頭から、と書いておきました。
新しいモジュールを挿入して、その先頭から貼り付けて下さい。
既に、
Option Compare Database
Option Explicit
が有る場合も、面倒なので上書きして下さい。

補足

なるほど、失礼しました。

さて、今度は「実行時エラー：抽出条件でデータ型が一致しません。」と出てしまします。
抽出条件も何も・・・？？？です。
すみません。