Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


11868 / 13645 ツリー ←次へ | 前へ→

【13578】検索して一つのCSVファイルに・・・ Mino_Boo 04/5/8(土) 0:59 質問[未読]
【13611】Re:検索して一つのCSVファイルに・・・ Hirofumi 04/5/9(日) 17:37 回答[未読]
【13654】Re:検索して一つのCSVファイルに・・・ ちゃっぴ 04/5/10(月) 17:48 回答[未読]

【13578】検索して一つのCSVファイルに・・・
質問  Mino_Boo  - 04/5/8(土) 0:59 -

引用なし
パスワード
   初めて投稿します。
VBA初心者です。
大変困っております。

あるフォルダーがあります。
そのフォルダーにはサブフォルダーが多々存在し、
そのサブフォルダーには複数のCSVファイルが存在しています。

あるフォルダー内から
下記のようにして、CSVファイルを全て探し・・・
Filename = "*" & 検索ファイル名 & "*.csv"

その該当するCSVファイルを、
ADD形式で一つの新しいCSVファイルに貼り付け、
まとめたいのです。

例えば・・・

※"0"で検索した場合、
 <<A01.csv>>
AAAAAAA
AAAA

 <<B02.csv>>
BBBBBB
BB
B

上記の該当したCSVファイルを下記の様にしたいです。
(作成するタイミングは検索した結果の順でもかまいません)
  ↓

<<New.csv>>
AAAAAAA
AAAA
BBBBBB
BB
B

該当するCSVファイルのデータ量は様々です。
それをひとつのファイルにまとめたいのですが、
検索した数百個もあるCSVファイルを開いては、
新しいCSVにコピペするのは効率が悪すぎ、
VBAで出来ないものかと思い投稿しました。

急ぎの件なので、
私としてもVBAを勉強しておりますが、時間があまりありません。
初心者で申し訳ありませんが、
誰か力を貸して下さい。

【13611】Re:検索して一つのCSVファイルに・・・
回答  Hirofumi E-MAIL  - 04/5/9(日) 17:37 -

引用なし
パスワード
   >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"ファイル名を全て取得(第4引数は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)
    'ファイルから1行読み込み
    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

【13654】Re:検索して一つのCSVファイルに・・・
回答  ちゃっぴ E-MAIL  - 04/5/10(月) 17:48 -

引用なし
パスワード
   FileSearchオブジェクトDir関数はパス名が長いと正常に動作しない場合があるので、お勧めしません。
http://support.microsoft.com/default.aspxscid=kb;JA;213983&Product=xlw2kINT

FileSystemObjectをつかってみては?

以下サンプル
------------------------------------------------------------------
Option Compare Binary      'バイナリモードで比較

'フォルダパスを指定(任意に変えてください)
Private Const cstrFolederPath   As String = "c:\"
'検索ファイル名(任意に変えてください、ワイルドカード"*"使用可)
Private Const cstrSearchName   As String = "*.csv"
'出力CSVファイル名(任意に変えてください)
Private Const cstrOutPutName   As String = "MargeData.csv"

Private objFSO          As Object  'ファイルシステムオブジェクト
Private objOutPutFile      As Object  '出力先CSVファイル
Private strUSearchName      As String  '大文字変換後の検索ファイル名

'********************************************************
'呼び出し部分
'********************************************************
Sub CallMargeCSV()
  Dim objTargetFolder As Object
  
  strUSearchName = UCase(cstrSearchName)
  
  'ファイルシステムオブジェクト取得
  objFSO = CreateObject("Scripting.FileSystemObject")
  '指定のフォルダオブジェクト取得
  objTargetFolder = objFSO.GetFolder(cstrFolederPath)
  '出力CSVファイル作成
  objOutPutFile = objFSO.OpenTextFile(cstrOutPutName, ForAppending, True)
  
  'CSVマージ呼び出し
  Call MargeCSV(objTargetFolder)
  
  objOutPutFile.Close   '出力CSVファイル閉じる
  '変数初期化
  Set objOutPutFile = Nothing
  Set objTargetFolder = Nothing
  Set objFSO = Nothing
End Sub

'********************************************************
'本体CSVファイルを検索し、データをマージ(再帰処理)
'********************************************************
Sub MargeCSV(ByVal objTargetFolder As Object)
  Dim objTargetFile As Object
  Dim objTargetSubFolder As Object
  
  'フォルダ中のファイルを検索
  For Each objTargetFile In objTargetFolder.Files
    '検索結果にマッチした場合
    If UCase(objTargetFile.Name) Like strUSearchName Then
      'テキストストリームオブジェクトとして開く
      With objTargetFile.OpenAsTextStream
        '最終行までループ
        Do Until .AtEndOfStream = True
          'CSVデータの追記
          objOutPutFile.WriteLine = .ReadLine
        Loop
        .Close   'テキストストリームオブジェクトを閉じる
      End With
    End If
  Next objTargetFile
  Set objTargetFile = Nothing
  
  'サブフォルダに対し再帰呼び出し
  For Each objTargetSubFolder In objTargetFolder.SubFolders
    Call MargeCSV(objTargetSubFolder)
  Next objTargetFile
  Set objTargetSubFolder = Nothing
  
  Set objTargetFolder = Nothing
  
End Sub
------------------------------------------------------------------
こんな感じです。

FileSystemObjectを使用しているので遅いです。
速度を重視するのであればWIN32API(FindFirstFile)を使用するしかないでしょう。

11868 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free