Excel VBA Queryを使って別のブックのシートをインポートするときのパターン

インポートするときのファイルの用意

C:\hoge\ListFile.xlsxというファイル作りこんなリストを作ってみた

Sheet4に作成します

新しいファイルで実験してみてください。
一応Sheet4を作成するか、あればクリアします。
既存のデータがないか注意してください。

データベースになりうる形式のシートからデータを絞り込んでインポートできます。

Excel2013ではExcelファイルをインポートするときは接続　ファイルから XMLファイルを選んですべてのファイルに変える

Excel2013でExcelファイルをExcelファイルにインポートする
データタブ
その他のデータソース
XMLデータインポート
ここでxmlファイル(.xml)を
すべてのファイル(.*)に変える
挿入したいExcelファイルを選択

コード[Excel2013][Excel2016]

xmlから読み込むモードで記録して若干整理したものが以下のコード

Sub xlsxfileconnectwithxml()
'xml からすべてのファイルでxlsxを選んだ場合
'Excel 2013 And Excel 2016
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Dim xlQrys As Excel.Queries, xlQry
Dim bl As Boolean
Const xlQryName = "Sheet1"
Const ShtName = "Sheet4"
Const xlsxFile = "C:\hoge\Listfile.xlsx"
bl = False
For Each ws In wb.Worksheets
If ws.Name = "Sheet4" Then
ws.Activate
ws.UsedRange.Clear
bl = True
Exit For
End If
Next ws
If bl = False Then
Set ws = wb.Worksheets.Add(after:=wb.Worksheets.Count, Count:=1)
ws.Name = ShtName
End If
'普通は不要
For Each xlQry In wb.Queries
xlQry.DELETE
Next
'普通は不要///ここまで
Call qry_Remove_Hidden_Names
ws.Activate
    wb.Queries.Add Name:=xlQryName, Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    ソース = Excel.Workbook(File.Contents(" & Chr(34) & xlsxFile & Chr(34) & "), null, true)," & Chr(13) & "" & Chr(10) & "    Sheet1_Sheet = ソース{[Item=""Sheet1"",Kind=""Sheet""]}[Data]," & Chr(13) & "" & Chr(10) & "    昇格されたヘッダー数 = Table.PromoteHeaders(Sheet1_Sheet, [PromoteAllScalars=true])," & Chr(13) & "" & Chr(10) & "    変更された型 = Table.TransformColumnTypes(昇格されたヘッダー数,{{""No"", Int64.Type}, {""Fruits"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    変更された型"

    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=Sheet1;Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [Sheet1] Where ([No] =1)")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = xlQryName
        .Refresh BackgroundQuery:=False
    End With
End Sub
Private Sub qry_Remove_Hidden_Names()
' Dimension variables.
Dim xName As Excel.Name
Dim Result As Variant
Dim Vis As Variant
' Loop once for each name in the workbook.
For Each xName In ActiveWorkbook.Names
If xName.Visible = False Then
' ...ask whether or not to delete the name.
Result = MsgBox(prompt:="Delete  Name " & _
Chr(10) & xName.Name & "?" & Chr(10) & _
"Which refers to: " & Chr(10) & xName.RefersTo, _
Buttons:=vbYesNoCancel)
' If the result is true, then delete the name.
If Result = vbYes Then
xName.DELETE
ElseIf Result = vbCancel Then
Exit Sub
End If
End If
' Loop to the next name.
Next xName
End Sub

出来上がりのイメージ

気づいた点

Excel2016で記録するとなぜか「変更された型」など日本語のコメントが入る
Call qry_Remove_Hidden_Namesはなくてもよい。実験で繰り返したとき名前が増えないようにしている。
またクエリ名も増えないようにしているが、
'普通は不要
For Each xlQry In wb.Queries
xlQry.DELETE
Next
'普通は不要///ここまで
の部分は普通は不要である。

クエリの書式のFromはクエリ名

.CommandText = Array("SELECT * FROM [Sheet1] Where ([No] =1)")
テーブル名、シート名ではないようだ。またWhereでNoフィールド名で絞り込みが可能。

Excel2016 ではExcelファイルをインポートするときはデータ データの取得 ファイル ブックから

コード[Excell2016]

これを記録して加工したものがこちら

Sub xlsxFileconnectwithfromBook()
'データの取得（接続）ファイルから >ブックからでxlsxを選んだ場合
'Excel 2016
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Dim xlQrys As Excel.Queries, xlQry
Dim bl As Boolean
Const xlQryName = "Sheet1 (2)"
Const ShtName = "Sheet4"
Const xlsxFile = "C:\hoge\Listfile.xlsx"
bl = False
'シート4を探し出しクリア、なければシートを作る
For Each ws In wb.Worksheets
If ws.Name = "Sheet4" Then
ws.Activate
ws.UsedRange.Clear
bl = True
Exit For
End If
Next ws
If bl = False Then
Set ws = wb.Worksheets.Add(after:=wb.Worksheets.Count, Count:=1)
ws.Name = ShtName
End If
'普通は不要
For Each xlQry In wb.Queries
xlQry.DELETE
Next
'普通は不要///ここまで
'これを単独でVBAのモジュールにコピーするときは、上記のコードの
'Private Sub qry_Remove_Hidden_Names()
'以下も一緒にコピーしてください。
Call qry_Remove_Hidden_Names
ws.Activate
    wb.Queries.Add Name:="Sheet1 (2)", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    ソース = Excel.Workbook(File.Contents(" & Chr(34) & xlsxFile & Chr(34) & "), null, true)," & Chr(13) & "" & Chr(10) & "    Sheet1_Sheet = ソース{[Item=""Sheet1"",Kind=""Sheet""]}[Data]," & Chr(13) & "" & Chr(10) & "    昇格されたヘッダー数 = Table.PromoteHeaders(Sheet1_Sheet, [PromoteAllScalars=true])," & Chr(13) & "" & Chr(10) & "    変更された型 = Table.TransformColumnTypes(昇格されたヘッダー数,{{""No"", Int64.Type}, {""Fruits"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    変更された型"

    With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""Sheet1 (2)"";Extended Properties=""""" _
        , Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [Sheet1 (2)] Where ([Sheet1 (2)].[Fruits]='Banana')")
        'From のあとは[] 角かっこで囲んだクエリ名 そして [クエリ名]ピリオド[フィールド名]は可能 [クエリ名]びっくり[フィールド名]はエラーで不可
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Sheet1__2" 'Displayでは()かっこが使えないようだ
        .Refresh BackgroundQuery:=False
    End With
End Sub

出来上がりのイメージ

気づいた点

フィールド名はピリオドは使えるが、びっくりはエラー

[Queryname].[Fieldname] ** Ok

[Queryname]![Fieldname] ** No

参考

注: 最大で 1,048,576 行および 16,384 列をインポートおよびエクスポートできます。
テキストファイルをインポートするにはWanichan
Excel(エクセル)上級講座：No.1 データのインポートとエクスポート
テキスト ファイル (.txt または .csv) のインポートまたはエクスポート - support.office.com