| |
>ADD形式で一つの新しいCSVファイルに貼り付け､
ADD形式って？で心配ですが、
ファイルをマージしていくならこんなものかな？
フォルダ内のファイル名を探すのにFileSearchオブジェクトを使用して、
ファイル名を取得していますが、FileSearchオブジェクトが上手く動かない場合が有るようなので
Dir関数版のコードも載せて有ります（コメントアウトして有ります）
以下のコードを標準モジュールに記述して下さい
Option Explicit
' アクティブなウィンドウのハンドルを取得する関数の宣言
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Public Sub CsvDataMerge()
Dim i As Long
Dim vntFileNames As Variant
Dim strPath As String
Dim vntSearchFile As Variant
Dim vntOutFile As Variant
Dim dfn As Integer
'読み込むCsvの有るフォルダを指定
strPath = GetFolderPath
If strPath = "" Then
Exit Sub
End If
'探索するファイル名を入力
vntSearchFile _
= Application.InputBox(Prompt:="検索ファイル名を入力", Type:=2)
'もし、キャンセルが押されたなら
If VarType(vntSearchFile) = vbBoolean Then
Exit Sub
End If
'探索ファイル名を作成
vntSearchFile = "*" & vntSearchFile & "*.csv"
'指定フォルダ内の".Csv"ファイル名を全て取得（第４引数はSubフォルダも探す）
'FileSearchオブジェクト版
If Not SearchFiles(vntFileNames, strPath, vntSearchFile, True) Then
Exit Sub
End If
'FileSearchオブジェクトが上手く行か無い場合
'Dir関数版
' If Not FilesList(vntFileNames, strPath, vntSearchFile, True) Then
' Exit Sub
' End If
'出力ファイル名を取得
If Not GetWriteFile(vntOutFile, ThisWorkbook.Path) Then
Exit Sub
End If
'空きファイルバファ番号を取得
dfn = FreeFile
'出力ファイルをOutPutモードでOpen
Open vntOutFile For Output As dfn
'複数選択されたファイルをシートに出力
For i = 1 To UBound(vntFileNames)
CSVRead vntFileNames(i), dfn
Next i
Close #dfn
Beep
MsgBox "処理が完了しました"
End Sub
Private Sub CSVRead(ByVal strFileName As String, _
dfo As Integer)
Dim dfn As Integer
Dim strBuff As String
'空きファイルバファ番号を取得
dfn = FreeFile
'ファイルをInputモードで開く
Open strFileName For Input As dfn
'ファイルエンドまで繰り返し
Do Until EOF(dfn)
'ファイルから１行読み込み
Line Input #dfn, strBuff
'出力ファイルへ出力
Print #dfo, strBuff
Loop
'ファイルをClose
Close #dfn
End Sub
Public Function SearchFiles(vntFileNames As Variant, _
ByVal strFilePath As String, _
ByVal strFile As String, _
Optional blnSubDir As Boolean = False) As Boolean
' FileSearchオブジェクトを使用して、フォルダ内のファイル名を取得
Dim i As Long
With Application.FileSearch
.LookIn = strFilePath
.SearchSubFolders = blnSubDir
.FileName = strFile
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) > 0 Then
ReDim vntFileNames(1 To .FoundFiles.Count)
For i = 1 To .FoundFiles.Count
vntFileNames(i) = .FoundFiles(i)
Next i
SearchFiles = True
End If
End With
End Function
Public Function GetWriteFile(vntFileName As Variant, _
Optional strFilePath As String) As Boolean
Dim strFilter As String
Dim strInitialFile As String
'フィルタ文字列を作成
strFilter = "CSV File (*.csv),*.csv," _
& "Text File (*.txt),*.txt"
'既定値のファイル名を設定
strInitialFile = vntFileName
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'「ファイルを保存」ダイアログを表示
vntFileName _
= Application.GetSaveAsFilename(vntFileName, strFilter, 1)
If vntFileName = False Then
Exit Function
End If
GetWriteFile = True
End Function
Public Function GetFolderPath() As String
Dim strTitle As String
Dim objFolder As Object
Dim hWnd As Long
Dim strTmpPath As String
Const BIF_RETURNONLYFSDIRS = &H1
Const ssfDESKTOP = &H0
Const CSIDL_WINDOWS = &H24
'アクティブなWindowのハンドルを取得
hWnd = GetForegroundWindow
' 表示タイトルを指定
strTitle = "フォルダを選択して下さい"
' フォルダ選択ダイアログを表示
Set objFolder = CreateObject("Shell.Application"). _
BrowseForFolder(hWnd, strTitle, _
BIF_RETURNONLYFSDIRS, CSIDL_WINDOWS)
' フォルダを選択したときは
If Not (objFolder Is Nothing) Then
' 選択フォルダを表示
With objFolder
' 親フォルダが存在するときは
If Not (.ParentFolder Is Nothing) Then
' 選択フォルダのフルパスを表示
strTmpPath = .Items.Item.Path
' 親フォルダのときは
Else
' フォルダ名を表示
strTmpPath = .Title
End If
End With
' Folderオブジェクトを破棄
Set objFolder = Nothing
End If
If strTmpPath <> "" And Right(strTmpPath, 1) <> "\" Then
strTmpPath = strTmpPath & "\"
End If
GetFolderPath = strTmpPath
End Function
Public Function FilesList(vntFileNames As Variant, _
ByVal strFolderPath As String, _
ByVal strSearchFile As String, _
Optional blnSubDir As Boolean = False) As Boolean
Dim i As Long
Dim j As Long
Dim strFolders() As String
Dim strFileName As String
'パスの最後に\を付加
If Right(strFolderPath, 1) <> "\" Then
strFolderPath = strFolderPath & "\"
End If
'フォルダのListを作成
ReDim strFolders(0)
'探し始めるフォルダを代入
strFolders(0) = strFolderPath
'フォルダをリストアップ
If blnSubDir Then
ListingFolders strFolderPath, strFolders(), _
UBound(strFolders) + 1, blnSubDir
End If
j = 1
ReDim vntFileNames(j)
For i = 0 To UBound(strFolders)
'ディレクトリ内の全ての標準ファイルを列挙
strFileName = Dir(strFolders(i) & strSearchFile)
Do Until strFileName = ""
ReDim Preserve vntFileNames(j)
vntFileNames(j) = strFolders(i) & strFileName
j = j + 1
strFileName = Dir
Loop
Next i
If vntFileNames(1) <> "" Then
FilesList = True
End If
End Function
Private Sub ListingFolders(ByVal strFilesPath As String, _
strDirList() As String, _
lngNextData As Long, _
blnSubDir As Boolean)
Dim i As Long
Dim j As Long
Dim strFileName As String
'結果用配列の書き込み位置を取得
i = lngNextData
'サブディレクトリの結果リストと、一時的なリストを作成
strFileName = Dir(strFilesPath, vbDirectory)
Do Until strFileName = ""
'現在のディレクトリと親ディレクトリを無視
If strFileName <> "." And strFileName <> ".." Then
'ディレクトリ以外を無視
If GetAttr(strFilesPath & strFileName) _
And vbDirectory Then
ReDim Preserve strDirList(i)
'結果リストに追加
strDirList(i) _
= strFilesPath & strFileName & "\"
i = i + 1
End If
End If
strFileName = Dir
Loop
j = lngNextData
lngNextData = i
'blnSubDir = True の時は最終階層まで再帰
If blnSubDir Then
'各ディレクトリを再帰的に処理
For i = j To lngNextData - 1
ListingFolders strDirList(i), _
strDirList(), lngNextData, blnSubDir
Next i
End If
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 04/5/9(日) 17:37 -
