毎日あるCSVファイルを読み込んで処理をするのですが・・

毎日CSVファイルをテキストファイルとして読み込んで処理をする作業をしたいのですが、そのファイルは毎日名前が変わります。そのため、そのマクロを実行するための同じフォルダの中に写して、名前を１に変更させて処理するようにしているのですが、もっと簡単にそのCSVファイルの名前を変更しなくても、また、同じフォルダに移さなくても読み込んで処理するようなマクロを組むことは可能でしょうか？マクロの記録でしかできないレベルなので困っています・・ちなみにその処理の最初だけ抜粋すると以下のとおりです。


With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & ThisWorkbook.Path & "\1.csv" _
, Destination:=Range("$A$2"))
.Name = "1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True

・・・・

No.1 回答者： naktak 回答日時： 2016/06/03 21:28

ルールによるでしょうね。

まさか、これを取り込んでほしいと思っているファイルを勝手に識別して、なんて不可能なので。

・都度ファイルを選択するダイアログを表示させ、任意のファイルを指定させる
・特定フォルダ内を走査して最初に見つかったcsvファイル
・特定フォルダ内にある、実行日などの特定ルールに則ったcsvファイル名
　によってファイルを決定

などのルール付けが必要だと思います。

この回答へのお礼

ご回答ありがとうございます。そのような方法自体は思い浮かぶのですが、質者通り、そういうもののマクロの記録ができないので困っています・・

お礼日時：2016/06/03 22:24

No.2 回答者： naktak 回答日時： 2016/06/03 23:02

> ご回答ありがとうございます。

そのような方法自体は思い浮かぶのですが、
> 質者通り、そういうもののマクロの記録ができないので困っています・・
はい、ですので、どのようにしたいかを提示していただければ、
正確な回答が可能だと思いますよ。
ここのサイトは、さすがにコンサルするサイトではありませんので。

フォルダに移さなくても、と仰いますが、ではファイルを選択するようにしようと考えたとき、逆にそれが手間だと感じる可能性もあります。
よって、どのような方法論で実現したいか、をもう少し落とし込んだ上で説明が必要だと思います。

この回答へのお礼

たびたびご回答ありがとうございます(*_*;
申し訳ありません。。おっしゃるとおりです。
今回のケースなのですが、実はそのCSVファイルはいつもZIPファイルになっていまして、それをこのマクロのある
フォルダに解凍して、「１」という名前に変更して、マクロで読み込ませていました。最終的にCSVファイルはなくなるので、
そのフォルダにはCSVファイルは基本的に一つしかありませんので、このマクロのあるフォルダ内を走査して最初に見つかったcsvファイル（ZIPファイルの中にある
CSVが読み込めたら最高なのですが。。）を走査して読み込ませる方法をご教授いただきたいです；

お礼日時：2016/06/04 00:06

No.3 回答者： naktak 回答日時： 2016/06/04 01:12

VBAが組み込まれているブックと同じ場所にあるzipファイルを解凍して、1.csvにファイル名をリネームし、後続処理を行わせます。

テキｔ－に作ったので、色々大前提があります。
　・複数zipファイルが存在しないこと
　・複数csvファイルが解凍されるならば、最後に解凍されたファイルが
　　対象になる

Public Sub test()
' zipファイルを解凍して1.csvにリネームする
Dim csvFilePath As String
csvFilePath = extractFile(ActiveWorkbook.Path, ActiveWorkbook.Path)
csvFilePath = rename(csvFilePath)

With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & csvFilePath _
, Destination:=Range("$A$2"))
.Name = "1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True

・・・

End Sub

'
' ファイルの解凍を行う
' @param targetDirectoryPath 走査するディレクトリ
' @param destPath 解凍先
' @return 最後に解凍されたcsvファイルパス
'
Public Function extractFile(targetDirectoryPath As String, destPath As Variant) As String
Const FOF_SILENT = &H4 '進捗ダイアログを表示しない。
Const FOF_NOCONFIRMATION = &H10 '上書き確認ダイアログを表示しない（[すべて上書き]と同じ）。

Dim fso As Object
Dim lastExtractFileName As String

Set fso = CreateObject("Scripting.FileSystemObject")

' ファイル内の全てのファイルを調べる
For Each File In fso.GetFolder(targetDirectoryPath).Files
If fso.GetextensionName(File) = "zip" Then
Dim shell As Object
Dim zipFile As Object
Dim destDirectory As Object
Set shell = CreateObject("Shell.Application")
Set zipFile = shell.Namespace(File.Path)
Set destDirectory = shell.Namespace(destPath)

For Each f In zipFile.Items
If Not f.IsFolder And Right(f.Name, 4) = ".csv" Then
destDirectory.CopyHere f, FOF_NOCONFIRMATION + FOF_SILENT
lastExtractFileName = f.Name
End If
Next
End If
Next

Set destDirectory = Nothing
Set zipFile = Nothing
Set shell = Nothing
Set fso = Nothing
extractFile = destPath & "\" & lastExtractFileName
End Function

'
' ファイル名を固定値に変更する
' @param targetFilePath ファイル名を変更するファイルパス
' @return ファイル名が変更されたファイルパス
'
Public Function rename(targetFilePath As String) As String
Dim destFilePath As String

Dim directoryPos As Integer
directoryPos = InStrRev(targetFilePath, "\")

destFilePath = Left(targetFilePath, directoryPos) & "1.csv"

Name targetFilePath As destFilePath

End Function

この回答へのお礼

ご回答ありがとうございます。まさかこんなに素晴らしいマクロができるとは思いませんでした。。
きちんと圧縮されたZIPファイルの中のCSVファイルを読み込んで、希望のファイルができあがりました。
実は、出来上がりのファイルは、 ActiveWorkbook.SaveAs Format(Date, "yymmdd") & "_データ" & ".xlsm"
ということでxlsmファイルが完成するようになっています。
そのため、１とリネームされたCSVファイルとZIPファイルが残っている状態なのですが、この２つは上の作業後終了と同時に
消すことは可能なのでしょうか？；

お礼日時：2016/06/04 01:38

No.4 回答者： WindFaller 回答日時： 2016/06/04 19:41

UnZip.dllが必要になりますから、会社向けとしてはふさわしくないかもしれません。

また、削除したファイルは、ゴミ箱に入っていますから、なくなっているわけではありません。

このマクロの特徴は、Zipファイルの中に二つ入っていた場合には、二つのファイルができるようにしてあります。
こちらは、特に必要なければ、フィードバック等は不要です。
今回と同じように、何年後かに、また、自分で見ることになるかもしれない、というだけのためです。

'//
Option Explicit
'要Unzip.dll (Vectorから）
Private Declare Function UnZip Lib "unzip32" (ByVal hWnd As Long, ByVal _
　　　　szCmdLine As String, ByVal szOutPut As String, ByVal wSize As Long) As Long
'http://www.red.oit-net.jp/tatsuya/vb/Unzip32.htm
Private Declare Function SHFileOperation Lib "shell32.dll" _
　　　　Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Type SHFILEOPSTRUCT
　　　　hWnd As Long
　　　　wFunc As Long
　　　　pFrom As String
　　　　pTo As String
　　　　fFlags As Integer
　　　　fAnyOperationsAborted As Long
　　　　hNameMappings As Long
　　　　lpszProgressTitle As String
End Type
Private Const FO_DELETE = &H3&　　'削除
Private Const FOF_ALLOWUNDO = &H40&　　 'ごみ箱へ
Private Const FOF_NOCONFIRMATION = &H10&　'確認なし
Private Const FOF_NOERRORUI = &H400&　　'エラーダイアログなし
Sub ExstractZiptoDest() 　'開始
　　'Zip解凍ツール
　　Dim orgPath As String '元のフォルダ (末尾は、\が必要）
　　orgPath = "C:\Temp\Test1\" ' =ThisWorkbook.Path
　　If Right$(orgPath, 1) <> "\" Then orgPath = orgPath & "\"
　　
　　Dim destPath As String　　'コピー先のフォルダ　(末尾は、\が必要）
　　destPath = "C:\Temp\Test2\" ' = Range("A2").Value
　　
　　If Right$(destPath, 1) <> "\" Then destPath = destPath & "\"
　　Dim FileOpt As String
　　Dim sOutput As String * 2048
　　Dim fn As Variant
　　Dim Ret As Long
　　Dim hWnd As Long
　　Dim Ar As Variant
　　Dim arFiles()　　As Variant
　　Dim a As Variant
　　Dim cnt As Long, i As Long
　　On Error GoTo ErrHandler
　　hWnd = Application.hWnd 'Excel2007以上
　　fn = Dir(orgPath & "*.zip", vbNormal)
　　Do While fn <> ""
　　　　If fn <> "." And fn <> ".." Then
　　　　　　If (GetAttr(orgPath & fn) And vbNormal) = vbNormal Then
　　　　　　　　ReDim Preserve arFiles(cnt)
　　　　　　　　arFiles(cnt) = orgPath & fn
　　　　　　　　cnt = cnt + 1
　　　　　　End If
　　　　End If
　　　　fn = Dir()
　　Loop
　　For i = 0 To UBound(arFiles)
　　　　FileOpt = "-x　　-o " & """" & arFiles(i) & """" & " """ & destPath & """"
　　　　Ret = UnZip(hWnd, FileOpt, sOutput, Len(sOutput))
　　　　sOutput = Left(sOutput, InStr(1, sOutput, vbNullChar, vbBinaryCompare) - 1)
　　　　Ar = Split(sOutput, Space(1), , vbBinaryCompare)
　　　　Call AfterTreatment(Ar, orgPath, destPath)
　　　　FileDelete arFiles(i)　　'ファイルをゴミ箱へ
　　Next i
ErrHandler:
　　If Err.Number <> 0 Then
　　　　MsgBox Err.Number & " : " & Err.Description
　　Else
　　　　MsgBox "正常に終了しました。", vbInformation
　　End If
End Sub
Sub AfterTreatment(Arr As Variant, orgPath As String, destPath As String)
'ファイル名の取り出し
　Dim n As Variant
　Dim i As Long
　Dim fn As String
　For Each n In Arr
　　 i = InStr(1, n, "/", vbBinaryCompare)
　　 If i > 0 Then
　　　　　　fn = Mid$(n, i + 1)
　　　　　　Call MakingXlFile(destPath, fn)
　　　　　　FileDelete destPath & fn
　　End If
　Next n
End Sub
Sub MakingXlFile(destPath As String, FileName As String)
'Excelブック生成　(複数対応）
Dim xlBk As Workbook
Dim fn As String
Dim j As Long
'別なファイルが入らないようにする
If Not StrConv(FileName, vbLowerCase) Like "*.csv" Then Exit Sub
fn = Format(Date, "yymmdd") & "_データ"
　Set xlBk = Workbooks.Open(destPath & FileName)
　With xlBk
　　　　　　'枝番付け
　　Do While Dir(destPath & fn & ".xlsm") <> ""
　　　　If InStrRev(fn, "-") > 0 Then
　　　　　　fn = Mid$(fn, 1, InStrRev(fn, "_") - 1)
　　　　End If
　　　　　　j = j + 1
　　　　　　fn = fn & "-" & CStr(j)
　　Loop
　　　　.SaveAs destPath & fn, xlOpenXMLWorkbookMacroEnabled
　　　　.Close False
End With
End Sub

Private Sub FileDelete(ByVal DelFile As String)
'削除
　　　　On Error Resume Next
　　　　Dim lpFileOp As SHFILEOPSTRUCT
　　　　Dim Ret　　 As Long
　　　　Dim myFlag　　 As Long
　　　　myFlag = FOF_ALLOWUNDO
　　　　myFlag = myFlag + FOF_NOCONFIRMATION
　　　　myFlag = myFlag + FOF_NOERRORUI
　　　　With lpFileOp
　　　　　　　　 .hWnd = Application.hWnd
　　　　　　　　 .wFunc = FO_DELETE
　　　　　　　　 .pFrom = DelFile
　　　　　　　　' .pTo = 操作先のファイル名・ディレクトリ名
　　　　　　　　 .fFlags = myFlag
　　　　End With
　　　　 If Dir(DelFile, vbNormal) <> "" And GetAttr(DelFile) <> vbDirectory Then
　　　　　　　　Ret = SHFileOperation(lpFileOp)
　　　　 End If
End Sub

この回答へのお礼

ご回答ありがとうございます！外部ツールをいれて稼働することもできるのですね！
参考にさせていただきます(^^)

お礼日時：2016/06/08 21:36

No.6 ベストアンサー 回答者： naktak 回答日時： 2016/06/06 13:28

> そのため、１とリネームされたCSVファイルとZIPファイルが残って

> いる状態なのですが、この２つは上の作業後終了と同時に
> 消すことは可能なのでしょうか？；

前回のコードに一部変な漏れがあったので、一緒に直したものを提示します。
また、エラーが発生した時にどうあるべきか、までは考慮してません。

'
' 解凍したファイルのパスリスト
'
'
Private Type extractPathList
ZipFilePath As String
CsvFilePath As String
End Type

Public Sub test()
' zipファイルを解凍して1.csvにリネームする
Dim pathList As extractPathList
pathList = extractFile(ActiveWorkbook.Path, ActiveWorkbook.Path)
pathList.CsvFilePath = rename(pathList.CsvFilePath)

' With ActiveSheet.QueryTables.Add(Connection:= _
' "TEXT;" & CsvFilePath _
' , Destination:=Range("$A$2"))
' .Name = "1"
' .FieldNames = True
' .RowNumbers = False
' .FillAdjacentFormulas = False
' .PreserveFormatting = True
'
' ・・・

' 1.csvファイル、zipファイルの削除
Kill pathList.CsvFilePath
Kill pathList.ZipFilePath

End Sub

'
' ファイルの解凍を行う
' @param targetDirectoryPath 走査するディレクトリ
' @param destPath 解凍先
' @return 最後に解凍されたcsvファイルパス
'
Private Function extractFile(targetDirectoryPath As String, destPath As Variant) As extractPathList
Const FOF_SILENT = &H4 '進捗ダイアログを表示しない。
Const FOF_NOCONFIRMATION = &H10 '上書き確認ダイアログを表示しない（[すべて上書き]と同じ）。

Dim fso As Object
Dim lastExtractFileName As String

Set fso = CreateObject("Scripting.FileSystemObject")

' ファイル内の全てのファイルを調べる
For Each file In fso.GetFolder(targetDirectoryPath).Files
If fso.GetextensionName(file) = "zip" Then
extractFile.ZipFilePath = file
Dim shell As Object
Dim zipFile As Object
Dim destDirectory As Object
Set shell = CreateObject("Shell.Application")
Set zipFile = shell.Namespace(file.Path)
Set destDirectory = shell.Namespace(destPath)

For Each f In zipFile.Items
If Not f.IsFolder And Right(f.Name, 4) = ".csv" Then
destDirectory.CopyHere f, FOF_NOCONFIRMATION + FOF_SILENT
lastExtractFileName = f.Name
End If
Next
End If
Next

Set destDirectory = Nothing
Set zipFile = Nothing
Set shell = Nothing
Set fso = Nothing
extractFile.CsvFilePath = destPath & "\" & lastExtractFileName
End Function

'
' ファイル名を固定値に変更する
' @param targetFilePath ファイル名を変更するファイルパス
' @return ファイル名が変更されたファイルパス
'
Private Function rename(targetFilePath As String) As String
Dim destFilePath As String

Dim directoryPos As Integer
directoryPos = InStrRev(targetFilePath, "\")

destFilePath = Left(targetFilePath, directoryPos) & "1.csv"
Name targetFilePath As destFilePath

rename = destFilePath
End Function

この回答へのお礼

naktak様！
か、完璧な動作が実現しました！！！！！
感謝してもしきれません・・

きちんとZIPもリネームしたCSVも消えて、目的のファイルだけ残ることができました。
この度はありがとうございました！

お礼日時：2016/06/08 21:37