[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『パワークエリ：CSVを選択してパワークエリでシートに出力したい』（まっち）
VBAでCSVを指定させて、パワークエリで加工した後、シートに出力したいのです。
■やってみたこと
Dim 指定ファイルのフルパス As String
Dim クエリ名前 As String
指定ファイルのフルパス = Application.GetOpenFilename("CSV,*.csv")
クエリ名前 = Replace(Dir(指定ファイルのフルパス), ".", "")
'
ActiveWorkbook.Queries.Add Name:=クエリ名前, Formula:= _
"let" & Chr(13) & "" & Chr(10) & _
" ソース = Csv.Document(File.Contents(""" & 指定ファイルのフルパス & """),[Delimiter="","", Columns=2, Encoding=932, QuoteStyle=QuoteStyle.None])," & Chr(13) & "" & Chr(10) & _
" 昇格されたヘッダー数 = Table.PromoteHeaders(ソース, [PromoteAllScalars=true])," & Chr(13) & "" & Chr(10) & _
" 変更された型 = Table.TransformColumnTypes(昇格されたヘッダー数,{{""区分"", Int64.Type}, {""内容"", type text}})" & Chr(13) & "" & Chr(10) & _
"in" & Chr(13) & "" & Chr(10) & _
" 変更された型"
Sheets.Add After:=ActiveSheet
With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
"OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=クエリ名前;Extended Properties=""""" _
, Destination:=Range("$A$1")).QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [" & クエリ名前 & "]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = False
.ListObject.DisplayName = クエリ名前
.Refresh BackgroundQuery:=False
End With
Selection.ListObject.QueryTable.Refresh BackgroundQuery:=False
End Sub
■結果
接続専用になってしまい、シートに出力できない
■試したこと
GetOpenFilenameで指定するのではなく、
フルパス名を手打ちしたコードにするとシートに出力できるのです。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
選択したCSVファイルが「てすと.csv」だったとして、
クエリ名前 = Replace(Dir(指定ファイルのフルパス), ".", "")
●●のところに、てすとcsv とテキストべた打ちするとOK
●●のところに、クエリ名前 だと接続専用
●●のところに、" & クエリ名前 & " でも接続専用
という感じです。
（まっち） 2022/10/05(水) 13:21
Location=""" & クエリ名前 & """
でした。
無駄なスレになってしまいました。
申し訳ございません。削除できればしたいです。
（まっち） 2022/10/05(水) 13:27
.CommandText = Array("SELECT * FROM [●●]")
のところでした。
選択したCSVファイルが「てすと.csv」だったとして、
クエリ名前 = Replace(Dir(指定ファイルのフルパス), ".", "")
●●のところに、てすとcsv とテキストべた打ちするとOK
●●のところに、クエリ名前 だと接続専用
●●のところに、" & クエリ名前 & " でも接続専用
●●のところに、"" & クエリ名前 & "" でも接続専用
●●のところに、""" & クエリ名前 & """ でも接続専用
（まっち） 2022/10/05(水) 14:00
VBAでクエリを作るのは以前から興味あったのでやってみました
Sub sample()
Dim csvFileName As String, QueryName As String
Dim newWS As Worksheet, newList As ListObject
csvFileName = Application.GetOpenFilename("CSV,*.csv")
QueryName = Replace(Dir(csvFileName), ".", "_")
On Error GoTo ErrQueryNameAlredyExist
ThisWorkbook.Queries.Add Name:=QueryName, Formula:="readcsv(""" & csvFileName & """)"
On Error GoTo 0
ThisWorkbook.Worksheets.Add After:=ThisWorkbook.Worksheets(1)
Set newWS = ThisWorkbook.Worksheets(2)
Set newList = newWS.ListObjects.Add( _
SourceType:=0, _
Source:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & QueryName & ";Extended Properties=""""", _
Destination:=Range("$A$1"))
With newList.QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [" & QueryName & "]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = False
.Refresh BackgroundQuery:=False
End With
Exit Sub
ErrQueryNameAlredyExist: Dim retry_Q As Integer retry_Q = retry_Q + 1 QueryName = Replace(Dir(csvFileName), ".", "_") & "_" & retry_Q Resume
End Sub
ListObject.DisplayName は指定しないと勝手に付けてくれるみたいなので指定せず
readcsvという名前の関数クエリを事前に作成しています。
(csv as text)=>
let
ソース = Csv.Document(File.Contents( csv ),[Delimiter=",", Columns=2, Encoding=932, QuoteStyle=QuoteStyle.None]),
昇格されたヘッダー数 = Table.PromoteHeaders(ソース, [PromoteAllScalars=true]),
変更された型 = Table.TransformColumnTypes(昇格されたヘッダー数,{{"区分", Int64.Type}, {"内容", type text}})
in
変更された型
（´・ω・`） 2022/10/05(水) 15:07
Dim 指定ファイルのフルパス As String
Dim クエリ名前 As Variant
Dim SE As Variant
指定ファイルのフルパス = Application.GetOpenFilename("CSV,*.csv")
クエリ名前 = Replace(Dir(指定ファイルのフルパス), ".", "")
SE = "SELECT * FROM [" & クエリ名前 & "]"
（中略）
.CommandText = Array(SE)
いただいたコード、解体して勉強させていただきます。
（まっち） 2022/10/05(水) 15:26
Sub test()
Dim p As String
Dim qryname As String
Dim ws As Worksheet
Dim f As String
Dim qry As WorkbookQuery
Dim tbl As ListObject
p = Application.GetOpenFilename("CSV,*.csv")
If p = "False" Then Exit Sub
qryname = Replace(Dir(p), ".", "")
f = "let" & Chr(13) & "" & Chr(10) & _
" ソース = Csv.Document(File.Contents(""" & p & """),[Delimiter="","", Columns=2, Encoding=932, QuoteStyle=QuoteStyle.None])," & Chr(13) & "" & Chr(10) & _
" 昇格されたヘッダー数 = Table.PromoteHeaders(ソース, [PromoteAllScalars=true])," & Chr(13) & "" & Chr(10) & _
" 変更された型 = Table.TransformColumnTypes(昇格されたヘッダー数,{{""区分"", Int64.Type}, {""内容"", type text}})" & Chr(13) & "" & Chr(10) & _
"in" & Chr(13) & "" & Chr(10) & _
" 変更された型"
Set qry = ActiveWorkbook.Queries.Add(Name:=qryname, Formula:=f)
Set ws = Sheets.Add(After:=ActiveSheet)
Set tbl = ws.ListObjects.Add( _
SourceType:=0, _
Source:="OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & qryname, _
Destination:=ws.Cells(1))
With tbl.QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [" & qryname & "]")
.Refresh BackgroundQuery:=False
End With
qry.Delete
tbl.Unlist
End Sub
（マナ） 2022/10/05(水) 19:06
Formula:=f
ちょっと感動です。
（まっち） 2022/10/06(木) 09:13
オートメーションエラー
例外が発生しました。
（まっち） 2022/10/06(木) 09:24
どこかで見覚えがある題材だなと思って探してきました。 [[20201006172606]] 私はこの前クエリ勉強したばかりなので、内容はあんまりわかりませんが… （.:*.ゆ ゅ） 2022/10/06(木) 10:11
検索はいままで、「Power Query」か「パワークエリ」でした。
「クエリ」も加えて検索するようにします。
マナさんのコード実行できました。
なぜ、最初はエラーがでていたのか謎ですが・・・
（まっち） 2022/10/06(木) 12:49
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.