Excel VBA質問箱 IV

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

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


67675 / 76732 ←次へ | 前へ→

【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

2 hits

【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 回答

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