Excel VBA ファイル操作

Excel VBA のトップに戻る
Excel VBA 目次

索引

CSVファイルに書き出し

　この項目は、「アプリケーションとしてのVBAアプリケーションとしてのVBA」の「CSVファイルの書き出し」を参考にさせていただきました。

　下の例は、C列に入力が有る行のみを、CSV出力しています。
　また、列方向の項目名は、2行目にあるため、2行目を使って、列数を取得しています。


Option Explicit

Sub C列に入力が有る行をCSV出力()

   Dim 処理行 As Integer
   Dim 最終行 As Integer
   Dim 処理列 As Integer
   Dim 最終列 As Integer
   Dim 保存するCSVのパスとファイル名 As String
   Dim 空きファイル番号 As Integer
   
   保存するCSVのパスとファイル名 = "C:\test\出力テスト.csv"
   
   ThisWorkbook.Worksheets("★仕様連絡書1996-").Activate
   
   最終行 = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row
   最終列 = Cells(2, ActiveSheet.Columns.Count).End(xlToLeft).Column
   
   
   空きファイル番号 = FreeFile
   
   '出力ファイルをオープンします
   Open 保存するCSVのパスとファイル名 For Output As #空きファイル番号
   
   For 処理行 = 2 To 最終行
      If Range("C1").Cells(処理行, 1).Value <> "" Then
      
         For 処理列 = 1 To 最終列 - 1
            '改行を挿入しないで書き出す ; を最後に付ける
            Write #空きファイル番号, Cells(処理行, 処理列).Value;
         Next
         '改行を挿入する
         Write #空きファイル番号, Cells(処理行, 最終列).Value
      End If
   
   Next
      
   'ファイルを閉じます
   Close #空きファイル番号

End Sub

　解説：
　Write # ステートメントは、シーケンシャル出力モード (Output または Append) で開いたファイルにデータを書き込む、ファイル入出力ステートメントです。
　構文
　Write #filenumber, [outputlist]
　Write # ステートメントの構文は、次の指定項目から構成されます。
指定項目 内容
filenumber 必ず指定します。任意のファイル番号を指定します。
outputlist 省略可能です。ファイルに出力するデータをカンマで区切られた数式または文字列式で指定します。

　Write # ステートメントを使用して書き込んだデータは、Input # ステートメントで読み込みます。
　引数 outputlist を省略して引数 filenumber の後にカンマ (,) を指定すると、空白行がファイルに出力されます。引数 outputlist に複数のデータを指定するときは、スペース、セミコロン (;)、またはカンマ (,) で区切って指定します。スペースとセミコロンは同じ働きをします。
　Write # ステートメントを使ってファイルに書き込んだデータは、国別情報の設定にかかわらず、Input # ステートメントで正しく解釈して読み込むことができます。 　Write # ステートメントは、Print # ステートメントと異なり、ファイルにデータを書き込むときにデータ項目の間にカンマ (,) を挿入します。文字列は、ダブル クォーテーション ("") で囲んで出力します。引数 outputlist には明示的に区切り文字を指定する必要はありません。Write # ステートメントはファイルに引数 outputlist の最後の文字を出力したあと、改行文字を挿入します。
　注意 Write # ステートメントで、"1,2""X" のようなクォーテーションを含む文字列を記述しないようにしてください。このような場合、独立した 2 つの文字列として認識されます。

この種類の目次に戻る↑　索引へ↓　トップページに戻る


固定長orTab区切テキストから、指定項目部分を切り出す

　月次処理で、大容量の固定長テキストのダンプ・ファイルが出力されます。このダンプ・ファイルを、いくつかの目的のため、Accessで容易に解析できるように、必要項目の条件を指定して、固定長テキストとして切り出すために作りました。
抽出条件を指定するインタフェース
　指定できる条件は、下記です。
(1)．必要な抽出項目を指定
(2)．項目の出力順序(列方向)
(3)．単一項目のフィルタ条件
(4)．項目間の値一致条件

このExcelマクロとサンプルファイルをダウンロードできます。
→PickOut2FixedText00.zip
 

Option Explicit
Option Base 1

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim エラー出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim 入力行文字数 As Integer
Dim 処理行カウンタ As Long
Dim 出力行カウンタ As Long
Dim 検索文字目 As Integer
Dim 地文字数 As Integer
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant
Dim 対象項目配列(500, 6) As Variant '開始位置、幅、フィルタ、対象除外、フィールド間一致、出力順序
Dim フィールド間一致 As Boolean
Dim 最終行 As Integer
Dim カウンタ As Integer  '入力ファイルの項目数
Dim 処理フィールド As Integer
Dim 処理行 As Integer

Dim ASCII以外除外 As Boolean
Dim 読み込みエラー件数 As Integer
Dim 処理結果 As String
Dim 出力項目数 As Integer
Dim 出力項目カウンタ As Integer
Dim 出力順序累積 As Integer
Dim 出力項目累積 As Integer
Dim 出力文字列配列() As String


Sub 固定長テキスト抽出()

   Call 入力ファイルを指定
   Call 抽出フィールドを読み込み
   Call テキストファイル入出力
   Call インポート定義作成
   
   MsgBox "処理が終了しました。" & vbNewLine & 処理結果, vbOKOnly
    
End Sub


Private Sub メッセージ作成()

   If ASCII以外除外 = True Then
      処理結果 = String(20, "*") & vbNewLine _
         & "入力行数= " & Format(処理行カウンタ, "#,##0") & vbNewLine _
         & "読み込みエラー件数= " & 読み込みエラー件数 & vbNewLine _
         & "出力行数= " & Format(出力行カウンタ, "#,##0") & vbNewLine _
         & "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。"
   Else
      処理結果 = String(20, "*") & vbNewLine _
         & "入力行数= " & Format(処理行カウンタ, "#,##0") & vbNewLine _
         & "読み込みエラー件数= 対象外(*** ASCII以外を除外 が False ***)" & vbNewLine _
         & "出力行数= " & Format(出力行カウンタ, "#,##0") & vbNewLine _
         & "処理時間は、" & Format(終了時刻 - 開始時刻, "nn分ss秒") & " でした。"
   End If
   
End Sub


Private Sub 入力ファイルを指定()

   ChDrive ActiveWorkbook.Path 'このExcelブックのパスをデフォルトのパスにする
   ChDir ActiveWorkbook.Path   'このExcelブックのパスをデフォルトのパスにする

   'ファイルを開くダイアログを使って、入力ファイルのフルパスを取得
   入力ファイル名 = Application.GetOpenFilename("固定長テキスト(*.txt;*.csv),*.txt;*.csv")
   If 入力ファイル名 = "False" Then End
   
   Debug.Print 入力ファイル名
   
End Sub


Private Sub 抽出フィールドを読み込み()

   ThisWorkbook.Worksheets("START").Activate
   
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
      
   カウンタ = 0
   出力項目カウンタ = 0
   出力項目数 = 0
   出力順序累積 = 0
   出力項目累積 = 0
   For 処理行 = 11 To 最終行
      カウンタ = カウンタ + 1
      
      対象項目配列(カウンタ, 1) = Range("G1").Cells(処理行, 1).Value '入力ファイルの開始位置
      
      If Range("B1").Cells(処理行, 1).Value = "" Then  '抽出対象でない場合、幅を強制ゼロにする
         対象項目配列(カウンタ, 2) = 0
      ElseIf IsNumeric(Range("B1").Cells(処理行, 1).Value) = True Then       '抽出対象の場合、入力ファイルの幅を取得
         対象項目配列(カウンタ, 2) = Range("H1").Cells(処理行, 1).Value      '項目の幅
         対象項目配列(カウンタ, 6) = Range("B1").Cells(処理行, 1).Value      '出力順序
         出力項目カウンタ = 出力項目カウンタ + 1
         出力順序累積 = 出力順序累積 + Range("B1").Cells(処理行, 1).Value
         If 出力項目数 < Range("B1").Cells(処理行, 1).Value Then
            出力項目数 = Range("B1").Cells(処理行, 1).Value
         End If
      Else
         MsgBox "出力順序に数値以外が指定されています。" _
            & vbNewLine & "プログラムを終了します。"
         End
      End If
      
      If Trim(Range("C1").Cells(処理行, 1).Value) <> "" Then 'フィルタに指定があれば
         対象項目配列(カウンタ, 3) = Trim(Range("C1").Cells(処理行, 1).Value) 'フィルタ値を取得
         対象項目配列(カウンタ, 4) = Range("D1").Cells(処理行, 1).Value       'TRUE:Include/FALSE:Exclude
      End If
      
      If Trim(Range("E1").Cells(処理行, 1).Value) <> "" Then 'フィールド間一致の指定がある場合
         対象項目配列(カウンタ, 5) = Trim(Range("E1").Cells(処理行, 1).Value)
      End If
      
      フィールド間一致 = Range("E10").Value
      ASCII以外除外 = Range("H1").Value
   
   Next 処理行
   
   If 出力項目数 <> 出力項目カウンタ Then
      MsgBox "出力順序の指定が、整数の昇順になっていません。" _
         & vbNewLine & "プログラムを終了します。"
      End
   End If
   
   For 出力項目カウンタ = 1 To 出力項目数
      出力項目累積 = 出力項目累積 + 出力項目カウンタ
   Next 出力項目カウンタ
   
   If 出力項目累積 <> 出力順序累積 Then
      MsgBox "出力順序の指定の整数に、重複があります。" _
         & vbNewLine & "プログラムを終了します。"
      End
   End If

End Sub


Private Sub テキストファイル入出力()

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト2 As Object   ' エラー出力用
   Dim 返答 As Integer
   Dim 正規表現オブジェクト As RegExp
   
   Set 正規表現オブジェクト = New RegExp
   正規表現オブジェクト.Pattern = "[^\x01-\x7E]" '2バイト文字

   '変換対象のファイル名から出力ファイル名を設定
   出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "_Extract" & ".txt"
   エラー出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "_ERROR" & ".txt"
   
   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   出力行カウンタ = 0
   

   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(入力モード)
   Set 入力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

   ' 指定ファイルをOPEN(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)
   Set 出力テキストストリームオブジェクト2 = _
   ファイルシステムオブジェクト.CreateTextFile(エラー出力ファイル名)
   
   '*************データの読み込み***********
   Do Until 入力テキストストリームオブジェクト.AtEndOfStream
   
      '入力ファイルの全ての行について、以下の処理を繰返す
      
      処理行カウンタ = 処理行カウンタ + 1
      ReDim 出力文字列配列(出力項目数) As String

      
      ' レコードの読み込み
      入力行 = 入力テキストストリームオブジェクト.ReadLine
      
      If (処理行カウンタ Mod 20000) = 0 Then
         Application.StatusBar = "☆" & Format(処理行カウンタ, "#,##0") & " 行目を読込み ☆"
      ElseIf (処理行カウンタ Mod 10000) = 0 Then
         Application.StatusBar = "★" & Format(処理行カウンタ, "#,##0") & " 行目を読込み ★"
      End If
      
      If ASCII以外除外 = True Then
         If 正規表現オブジェクト.Test(入力行) = True Then
            出力テキストストリームオブジェクト2.WriteLine Format(処理行カウンタ, "#,##0")
            出力テキストストリームオブジェクト2.WriteLine 入力行
            読み込みエラー件数 = 読み込みエラー件数 + 1
            GoTo スキップ
         End If
      End If
      

      For 処理フィールド = 1 To カウンタ '入力ファイルの項目数

        If 対象項目配列(処理フィールド, 6) <> "" Then
         '出力ファイルに含めない項目は、出力順序：対象項目配列(処理フィールド, 6) が空白なので、取り込まれない
      
         If Trim(対象項目配列(処理フィールド, 3)) = "" Then 'フィルタ指定無し
            If 対象項目配列(処理フィールド, 5) = "" Then 'フィールド間一致指定無し
               出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
            Else 'フィールド間一致指定あり
               If フィールド間一致 = True Then
                  If Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) _
                  = Trim(Mid(入力行, 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 1), 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 2))) Then
                  'フィールドの値が一致している場合
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                  Else
                     'フィールドの値が一致していない場合
                     GoTo スキップ    '出力ファイルに、この入力行を含めない
                  End If
               Else 'フィールド間一致を除外
                  If Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) _
                  = Trim(Mid(入力行, 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 1), 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 2))) Then
                  'フィールドの値が一致している場合
                     GoTo スキップ    '出力ファイルに、この入力行を含めない
                  Else
                     'フィールドの値が一致していない場合
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                  End If
               End If
            End If
         Else
         
            If 対象項目配列(処理フィールド, 4) = True Then 'フィルタを対象として指定した場合
               If Trim(対象項目配列(処理フィールド, 3)) = Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) Then
                            
                  If 対象項目配列(処理フィールド, 5) = "" Then 'フィールド間一致指定無し
                                                   'フィルタに合致するデータを出力
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                  Else 'フィールド間一致指定あり
                     If フィールド間一致 = True Then
                        If Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) _
                        = Trim(Mid(入力行, 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 1), 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 2))) Then
                        'フィールドの値が一致している場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                        Else
                           'フィールドの値が一致していない場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        End If
                     Else 'フィールド間一致を除外
                        If Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) _
                        = Trim(Mid(入力行, 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 1), 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 2))) Then
                        'フィールドの値が一致している場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        Else
                           'フィールドの値が一致していない場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                        End If
                     
                     End If
                  End If
                  
               ElseIf Trim(対象項目配列(処理フィールド, 3)) = "$" _
                  And Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) = "" Then
                            
                  If 対象項目配列(処理フィールド, 5) = "" Then 'フィールド間一致指定無し
                                                   'フィルタに合致するデータを出力
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                  Else 'フィールド間一致指定あり
                     If フィールド間一致 = True Then
                        If Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) _
                        = Trim(Mid(入力行, 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 1), 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 2))) Then
                        'フィールドの値が一致している場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                        Else
                           'フィールドの値が一致していない場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        End If
                     Else 'フィールド間一致を除外
                        If Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) _
                        = Trim(Mid(入力行, 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 1), 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 2))) Then
                        'フィールドの値が一致している場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        Else
                           'フィールドの値が一致していない場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                        End If
                     
                     End If
                  End If

               Else
                  GoTo スキップ    '出力ファイルに、この入力行を含めない
               End If
               
            Else                                   'フィルタを除外として指定した場合
               If Trim(対象項目配列(処理フィールド, 3)) = "$" _
                  And Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) = "" Then

                     'ブランク「$」を除外「FALSE」のとき、フィールドの値が空白なら
                     GoTo スキップ    '出力ファイルに、この入力行を含めない

               ElseIf Trim(対象項目配列(処理フィールド, 3)) <> Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) Then

                  If 対象項目配列(処理フィールド, 5) = "" Then 'フィールド間一致指定無し
                                                   'フィルタに合致しないデータを出力
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                  Else 'フィールド間一致指定あり
                     If フィールド間一致 = True Then
                        If Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) _
                        = Trim(Mid(入力行, 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 1), 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 2))) Then
                        'フィールドの値が一致している場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                        Else
                           'フィールドの値が一致していない場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        End If
                     Else 'フィールド間一致を除外
                        If Trim(Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))) _
                        = Trim(Mid(入力行, 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 1), 対象項目配列(Val(対象項目配列(処理フィールド, 5)) - 10, 2))) Then
                        'フィールドの値が一致している場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        Else
                           'フィールドの値が一致していない場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Mid(入力行, 対象項目配列(処理フィールド, 1), 対象項目配列(処理フィールド, 2))
                        End If
                     End If
                  End If

               Else
                  GoTo スキップ    '出力ファイルに、この入力行を含めない
               End If
            End If
         End If
        End If
      Next 処理フィールド
      
      出力行カウンタ = 出力行カウンタ + 1
      
      出力行 = ""
      For 出力項目カウンタ = 1 To 出力項目数
         出力行 = 出力行 & 出力文字列配列(出力項目カウンタ)
      Next 出力項目カウンタ
      
      出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き
      
スキップ:
      If 出力行カウンタ = 1 Then
         返答 = MsgBox(出力行, vbInformation + vbYesNo, "出力行1行目の内容です")
         'vbInformation は、情報メッセージ アイコン。
         'vbYesNo は、[はい] と [いいえ] のボタンを表示。
         If 返答 = 7 Then End    ' 6*Yes, 7:No
         開始時刻 = Now()
      End If

   Loop ' 最終行まで繰り返す
   
   '**************終了処理*********************
   Application.StatusBar = "■" & Format(処理行カウンタ, "#,##0") & " 最終行まで読込み完了 ■"

   終了時刻 = Now()
   
   Call メッセージ作成
   
   出力テキストストリームオブジェクト2.WriteLine 処理結果
   
   ' 指定ファイルをCLOSE
   入力テキストストリームオブジェクト.Close
   Set 入力テキストストリームオブジェクト = Nothing
   
   出力テキストストリームオブジェクト2.Close
   Set 出力テキストストリームオブジェクト2 = Nothing
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
   
   Set ファイルシステムオブジェクト = Nothing
   Set 正規表現オブジェクト = Nothing

End Sub


Private Sub インポート定義作成()

   Dim 追加シート名初期 As String
   Dim 追加シート名 As String
   Dim 重複 As Integer
   Dim シート As Worksheet
   Dim シート数 As Integer
   Dim ワークシート As Worksheet

   Set ワークシート = Worksheets("START")
   
   追加シート名初期 = "インポート定義"
   追加シート名 = 追加シート名初期

   For 重複 = 1 To 100
   ' 100枚まで追加しても重複しないように追番を設定します。
       For Each シート In Worksheets
           If シート.Name = 追加シート名 Then
               追加シート名 = 追加シート名初期 & "(" & 重複 & ")"
           End If
       Next シート
   Next 重複
   シート数 = Worksheets.Count
   Worksheets("テンプレート").Copy After:=Worksheets(シート数)
   ActiveSheet.Name = 追加シート名

   カウンタ = 0
   For 処理行 = 11 To 最終行
      If ワークシート.Range("B1").Cells(処理行, 1).Value <> "" Then
         
         Range("A2").Cells(ワークシート.Range("B1").Cells(処理行, 1).Value, 1).Value = ワークシート.Range("A1").Cells(処理行, 1).Value
         Range("B2").Cells(ワークシート.Range("B1").Cells(処理行, 1).Value, 1).Value = ワークシート.Range("F1").Cells(処理行, 1).Value
         Range("D2").Cells(ワークシート.Range("B1").Cells(処理行, 1).Value, 1).Value = ワークシート.Range("H1").Cells(処理行, 1).Value
         Range("E2").Cells(ワークシート.Range("B1").Cells(処理行, 1).Value, 1).Value = "いいえ"
         Range("F2").Cells(ワークシート.Range("B1").Cells(処理行, 1).Value, 1).Value = "FALSE"
      End If
      
   Next 処理行
   
   Range("C2").Value = 1
   For 出力項目カウンタ = 2 To 出力項目数
         Range("C2").Cells(出力項目カウンタ, 1).Value = Range("C2").Cells(出力項目カウンタ - 1, 1).Value + Range("D2").Cells(出力項目カウンタ - 1, 1).Value
   Next 出力項目カウンタ
   
   Set ワークシート = Nothing
   
End Sub

　上は、元のテキストが固定長ファイルです。下は、元ファイルが Tab 区切りのバージョンです。

Option Explicit
Option Base 1

Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim エラー出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim 入力行文字数 As Integer
Dim 処理行カウンタ As Long
Dim 出力行カウンタ As Long
Dim 検索文字目 As Integer
Dim 地文字数 As Integer
Dim 開始時刻 As Variant
Dim 終了時刻 As Variant
'                                      1        2      3        4             5              6
Dim 対象項目配列(500, 6) As Variant '開始位置、幅、フィルタ、対象除外、フィールド間一致、出力順序
Dim フィールド間一致 As Boolean
Dim 最終行 As Integer
Dim カウンタ As Integer  '入力ファイルの項目数
Dim 処理フィールド As Integer
Dim 処理行 As Integer

Dim ASCII以外除外 As Boolean
Dim 読み込みエラー件数 As Integer
Dim 処理結果 As String
Dim 出力項目数 As Integer
Dim 出力項目カウンタ As Integer
Dim 出力順序累積 As Integer
Dim 出力項目累積 As Integer
Dim 出力文字列配列() As String


Sub 固定長テキスト抽出()

   Call 入力ファイルを指定
   Call 抽出フィールドを読み込み
   Call テキストファイル入出力
   Call インポート定義作成
   
   MsgBox "処理が終了しました。" & vbNewLine & 処理結果, vbOKOnly
    
End Sub



Private Sub テキストファイル入出力()

   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim 入力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト As Object    ' TextStream
   Dim 出力テキストストリームオブジェクト2 As Object   ' エラー出力用
   Dim 返答 As Integer
   Dim 正規表現オブジェクト As RegExp
   
   Dim Tab位置() As Integer '行端左と右端の両方もTabと見なす
   Dim Tab数 As Integer
   
   Set 正規表現オブジェクト = New RegExp
   正規表現オブジェクト.Pattern = "[^\x01-\x7E]" '2バイト文字

   '変換対象のファイル名から出力ファイル名を設定
   出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "_Extract" & ".txt"
   エラー出力ファイル名 = Left(入力ファイル名, Len(入力ファイル名) - 4) & "_ERROR" & ".txt"
   
   '********************************
   'ファイルのオープン。
   処理行カウンタ = 0
   出力行カウンタ = 0
   
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(入力モード)
   Set 入力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)

   ' 指定ファイルをOPEN(出力モード)
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)
   Set 出力テキストストリームオブジェクト2 = _
   ファイルシステムオブジェクト.CreateTextFile(エラー出力ファイル名)
   
   '*************データの読み込み***********
   Do Until 入力テキストストリームオブジェクト.AtEndOfStream
   
      '入力ファイルの全ての行について、以下の処理を繰返す
      
      処理行カウンタ = 処理行カウンタ + 1
      ReDim 出力文字列配列(出力項目数) As String

      ' レコードの読み込み
      入力行 = 入力テキストストリームオブジェクト.ReadLine
      
      If (処理行カウンタ Mod 20000) = 0 Then
         Application.StatusBar = "☆" & Format(処理行カウンタ, "#,##0") & " 行目を読込み ☆"
      ElseIf (処理行カウンタ Mod 10000) = 0 Then
         Application.StatusBar = "★" & Format(処理行カウンタ, "#,##0") & " 行目を読込み ★"
      End If
      
      If ASCII以外除外 = True Then
         If 正規表現オブジェクト.Test(入力行) = True Then
            出力テキストストリームオブジェクト2.WriteLine Format(処理行カウンタ, "#,##0")
            出力テキストストリームオブジェクト2.WriteLine 入力行
            読み込みエラー件数 = 読み込みエラー件数 + 1
            GoTo スキップ
         End If
      End If
      
      
      'Tab位置を取得
      ReDim Tab位置(カウンタ + 1)
      
      For Tab数 = 1 To カウンタ
         If Tab数 = 1 Then
            Tab位置(Tab数) = 0 '★行端左と右端の両方もTabと見なすことで、項目を抽出するコードを画一化できる！
         Else
            Tab位置(Tab数) = InStr(Tab位置(Tab数 - 1) + 1, 入力行, vbTab)
         End If
      Next Tab数
      Tab位置(Tab数) = Len(入力行) + 1 '★行端左と右端の両方もTabと見なして、項目を抽出するコードを画一化！
'Stop
      
      
      For 処理フィールド = 1 To カウンタ '入力ファイルの項目数

        If 対象項目配列(処理フィールド, 6) <> "" Then
         '出力ファイルに含めない項目は、出力順序：対象項目配列(処理フィールド, 6) が空白なので、取り込まれない
      
         If Trim(対象項目配列(処理フィールド, 3)) = "" Then 'フィルタ指定無し
            If 対象項目配列(処理フィールド, 5) = "" Then 'フィールド間一致指定無し
               出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))

            Else 'フィールド間一致指定あり
'Stop
               If フィールド間一致 = True Then
                  If Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) _
                  = Mid(入力行, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) + 1, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10 + 1) - Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) - 1) Then
                  'フィールドの値が一致している場合
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                  Else
                     'フィールドの値が一致していない場合
                     GoTo スキップ    '出力ファイルに、この入力行を含めない
                  End If
               Else 'フィールド間一致を除外
                  If Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) _
                  = Mid(入力行, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) + 1, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10 + 1) - Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) - 1) Then
                  'フィールドの値が一致している場合
                     GoTo スキップ    '出力ファイルに、この入力行を含めない
                  Else
                     'フィールドの値が一致していない場合
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                  End If
               End If
            End If
         Else
         
            If 対象項目配列(処理フィールド, 4) = True Then 'フィルタを対象として指定した場合
               If Trim(対象項目配列(処理フィールド, 3)) = Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) Then
                            
                  If 対象項目配列(処理フィールド, 5) = "" Then 'フィールド間一致指定無し
                                                   'フィルタに合致するデータを出力
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                  Else 'フィールド間一致指定あり
                     If フィールド間一致 = True Then
                        If Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) _
                  = Mid(入力行, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) + 1, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10 + 1) - Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) - 1) Then
                        'フィールドの値が一致している場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                        Else
                           'フィールドの値が一致していない場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        End If
                     Else 'フィールド間一致を除外
                        If Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) _
                  = Mid(入力行, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) + 1, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10 + 1) - Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) - 1) Then
                        'フィールドの値が一致している場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        Else
                           'フィールドの値が一致していない場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                        End If
                     End If
                  End If
                  
               ElseIf Trim(対象項目配列(処理フィールド, 3)) = "$" _
                  And Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) = "" Then
                            
                  If 対象項目配列(処理フィールド, 5) = "" Then 'フィールド間一致指定無し
                                                   'フィルタに合致するデータを出力
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                  Else 'フィールド間一致指定あり
                     If フィールド間一致 = True Then
                        If Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) _
                  = Mid(入力行, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) + 1, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10 + 1) - Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) - 1) Then
                        'フィールドの値が一致している場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                        Else
                           'フィールドの値が一致していない場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        End If
                     Else 'フィールド間一致を除外
                        If Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) _
                  = Mid(入力行, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) + 1, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10 + 1) - Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) - 1) Then
                        'フィールドの値が一致している場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        Else
                           'フィールドの値が一致していない場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                        End If
                     End If
                  End If
               Else
                  GoTo スキップ    '出力ファイルに、この入力行を含めない
               End If
            Else                                   'フィルタを除外として指定した場合
               If Trim(対象項目配列(処理フィールド, 3)) = "$" _
                  And Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) = "" Then

                     'ブランク「$」を除外「FALSE」のとき、フィールドの値が空白なら
                     GoTo スキップ    '出力ファイルに、この入力行を含めない

               ElseIf Trim(対象項目配列(処理フィールド, 3)) <> Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) Then

                  If 対象項目配列(処理フィールド, 5) = "" Then 'フィールド間一致指定無し
                                                   'フィルタに合致しないデータを出力
                     出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                  Else 'フィールド間一致指定あり
                     If フィールド間一致 = True Then
                        If Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) _
                  = Mid(入力行, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) + 1, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10 + 1) - Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) - 1) Then
                        'フィールドの値が一致している場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                        Else
                           'フィールドの値が一致していない場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        End If
                     Else 'フィールド間一致を除外
                        If Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) _
                  = Mid(入力行, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) + 1, Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10 + 1) - Tab位置(Val(対象項目配列(処理フィールド, 5)) - 10) - 1) Then
                        'フィールドの値が一致している場合
                           GoTo スキップ    '出力ファイルに、この入力行を含めない
                        Else
                           'フィールドの値が一致していない場合
                           出力文字列配列(対象項目配列(処理フィールド, 6)) = Left(Mid(入力行, Tab位置(処理フィールド) + 1, Tab位置(処理フィールド + 1) - Tab位置(処理フィールド) - 1) & Space(対象項目配列(処理フィールド, 2)), 対象項目配列(処理フィールド, 2))
                        End If 'フィルタの一致、不一致
                     End If 'フィールド間一致を対象とするか除外するか
                  End If   'フィールド間一致指定の有無
               Else
                  GoTo スキップ    '出力ファイルに、この入力行を含めない
               End If 'フィルタへの合致
            End If 'フィルタを対象として指定したかどうか
         End If 'フィルタ指定の有無
        End If '出力順序指定が空白かどうか
      Next 処理フィールド
      
      出力行カウンタ = 出力行カウンタ + 1
      
      出力行 = ""
      For 出力項目カウンタ = 1 To 出力項目数
         出力行 = 出力行 & 出力文字列配列(出力項目カウンタ)
      Next 出力項目カウンタ
      
      出力テキストストリームオブジェクト.WriteLine 出力行         ' 改行(CrLf)付き
      
スキップ:
      If 出力行カウンタ = 1 Then
'Stop
         返答 = MsgBox(出力行, vbInformation + vbYesNo, "出力行1行目の内容です")
         'vbInformation は、情報メッセージ アイコン。
         'vbYesNo は、[はい] と [いいえ] のボタンを表示。
         If 返答 = 7 Then End    ' 6*Yes, 7:No
         開始時刻 = Now()
      End If

   Loop ' 最終行まで繰り返す
   
   '**************終了処理*********************
   Application.StatusBar = "■" & Format(処理行カウンタ, "#,##0") & " 最終行まで読込み完了 ■"

   終了時刻 = Now()
   
   Call メッセージ作成
   
   出力テキストストリームオブジェクト2.WriteLine 処理結果
   
   ' 指定ファイルをCLOSE
   入力テキストストリームオブジェクト.Close
   Set 入力テキストストリームオブジェクト = Nothing
   
   出力テキストストリームオブジェクト2.Close
   Set 出力テキストストリームオブジェクト2 = Nothing
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
   
   Set ファイルシステムオブジェクト = Nothing
   Set 正規表現オブジェクト = Nothing

End Sub

この種類の目次に戻る↑　索引へ↓　トップページに戻る


指定フォルダの直下のサブフォルダの全てのファイルを検索(VBA側でフォルダを指定)

　該当のフォルダにある複数フォルダ内の全てのファイルのデータを、串刺しで集計したり、データ抽出したいことかあります。
　ここで紹介する例は、月別のフォルダに登録されている、日別のログファイルを、串刺しにして、必要なデータを抽出して、総括表を作るときに使うものです。
　抽出元のログ・ファイルは、固定長ファイルです。抽出したデータは、CSV形式(""とカンマで区切っています)で、出力しています。

　このマクロは、Excelの登録されたフォルダにある同一レベルの全てのフォルダの，直下のファイルのみを、対象としています。

Option Explicit

Dim 主キー As String
Dim 作成日 As String
Dim キー As String
Dim 属性データ As String
Dim 入力ファイル名 As String
Dim 出力ファイル名 As String
Dim 入力行 As String
Dim 出力行 As String
Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
Dim 入力テキストストリームオブジェクト As Object    ' TextStream
Dim 出力テキストストリームオブジェクト As Object    ' TextStream
Dim 現在のパス As String
Dim フォルダ As Object
Dim サブフォルダ As Object
Dim ファイル As Object
Dim フォルダパス As String
Dim 開始日時 As Variant
Dim 終了日時 As Variant
Dim 区切り As String


Sub 属性データ抽出()

    開始日時 = Now                ' 開始時刻を変数に格納します。
    
    区切り = Chr(34) & "," & Chr(34) ' ","

   現在のパス = ActiveWorkbook.Path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   
   ' 指定ファイルをOPEN(出力モード)
   出力ファイル名 = 現在のパス & "\" & "集計結果リスト.txt"
   Set 出力テキストストリームオブジェクト = _
   ファイルシステムオブジェクト.CreateTextFile(出力ファイル名)
   
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)

   '★Excelの存在するフォルダの全てのフォルダを対象
    For Each サブフォルダ In フォルダ.SubFolders

      '★上で指定したフォルダ内の、全てのファイルを対象に検索
      For Each ファイル In サブフォルダ.Files
      
         入力ファイル名 = ファイル.Path
          ' 指定ファイルをOPEN(入力モード)
          Set 入力テキストストリームオブジェクト = _
          ファイルシステムオブジェクト.OpenTextFile(入力ファイル名, 1)
      
         '*************データの読み込み***********
           Do Until 入力テキストストリームオブジェクト.AtEndOfStream
              
              ' レコードの読み込み
              入力行 = 入力テキストストリームオブジェクト.ReadLine
              
              If Len(入力行) > 125 Then
                  属性データ = Trim(Mid(入力行, 124, 2))
                  If 属性データ <> "" Then
                     主キー = Mid(入力行, 8, 4)
                     作成日 = Mid(入力行, 22, 8)
                     キー = Trim(Mid(入力行, 43, 20))
   
                     出力行 = Chr(34) & 主キー & 区切り & 作成日 & 区切り _
                     & キー & 区切り & 属性データ & Chr(34)
                     出力テキストストリームオブジェクト.WriteLine 出力行  ' 改行(CrLf)付き
                  End If
              End If
              ' 最終行まで繰り返す
          Loop
      
         ' 指定ファイルをCLOSE
         入力テキストストリームオブジェクト.Close
         Set 入力テキストストリームオブジェクト = Nothing

      Next '★ファイル
    Next '★フォルダ
    
   出力テキストストリームオブジェクト.Close
   Set 出力テキストストリームオブジェクト = Nothing
    
   Set ファイルシステムオブジェクト = Nothing
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

　解説：
　Workbook オブジェクトの Path プロパティは、指定されたアプリケーションの絶対パスを表す文字列を返します。
　パス末尾の円記号 (\) とアプリケーション名は含みません。値の取得のみ可能です。文字列型 (String) の値を使用します。

expression.Path

expression 必ず指定します。対象となるオブジェクトへの参照を返すオブジェクト式を指定します。

この種類の目次に戻る↑　索引へ↓　トップページに戻る


ブックを開く。保存しないで閉じる

　マクロから、マクロを登録したブックとは別のブックを開いて、データを読み込んで、そのまま閉じる操作です。
　下の例は、品目番号の属性データのマスタを登録したブックを開きます。そして、保存してある品目番号の属性データを、配列に読み込みます。そして、ブックは、そのまま、閉じる、一連の動作の部分です。
　配列に読み込んだデータは、その後、マクロ側で参照・検索して、使います。

　ブックを開くときに、名前をつけた Workbook オブジェクトに、代入して、以降の指定を容易にしています。


   Dim 品目属性Book As Workbook

   ThisWorkbook.Worksheets("スタート").Activate  'マクロを登録してあるブックの「I1」セルに、開きたいブックのパスが書かれています。
   
   '品目属性情報を配列に格納
   Set 品目属性Book = Workbooks.Open(Filename:=Range("I1").Value, ReadOnly:=True) 'ブックを読み取り専用で開く
   '読み取り専用とした方が、開く速度が速い
      
   品目属性Book.Worksheets("品目マスタ").Activate
   品目マスタ配列 = Range("A1").CurrentRegion      '品目マスタの内容を、配列に読み込む
      
   品目属性Book.Close savechanges:=False           '保存せずにブックを閉じる


この種類の目次に戻る↑　索引へ↓　トップページに戻る


サブフォルダの全てのファイルをフォルダに移動

　Excel ブックを保存したフォルダのサブフォルダにある全てのファイルを、このフォルダに、ファイル名にサブフォルダ名を付加した上で移動するために作成しました。

このマクロをダウンロードできます。→MoveFilesFromSubfoldersToFolderVBA01.xls

ダウンロードした Excel を実行できるようにするために ファイルのプロパティの「全般」タブで、ブロックを解除して下さい。

Option Explicit

'00：2024/03/28：作成
'01：2024/03/30：フォルダ名をファイル名に付けないオプション

Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
Dim 現在のパス As String
Dim 入力ファイルフルパス As String
Dim 入力ファイル名 As String
Dim フォルダ As Object
Dim サブフォルダ As Object
Dim サブフォルダ名 As String
Dim ファイル As Object
Dim フォルダパス As String
Dim 開始日時 As Variant
Dim 終了日時 As Variant


Sub サブフォルダからファイルを移動()

   開始日時 = Now                ' 開始時刻を変数に格納します。
    
   現在のパス = ActiveWorkbook.Path
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
   Set フォルダ = ファイルシステムオブジェクト.GetFolder(現在のパス)

   '★この Excel ブックの存在するフォルダの全てのサブフォルダを対象
    For Each サブフォルダ In フォルダ.SubFolders
      サブフォルダ名 = サブフォルダ.Name
      
      '進捗状況をステータスバーに表示
      Application.StatusBar = サブフォルダ名

      '★上で指定したフォルダ内の、全てのファイルを対象に処理
      For Each ファイル In サブフォルダ.Files
      
         入力ファイルフルパス = ファイル.Path
         入力ファイル名 = _
         Right(入力ファイルフルパス, Len(入力ファイルフルパス) - InStrRev(入力ファイルフルパス, "\"))
'         Stop
         
         '************* サブフォルダのファイルを上のフォルダに移動 ***********

         '移動には VBA の FileCopy を使わずに、ファイルシステムオブジェクトの MoveFile を使う
         
         If Range("H3").Value = True Then  'サブフォルダ名をファイル名の頭に付ける
            ファイルシステムオブジェクト.MoveFile _
            入力ファイルフルパス, 現在のパス & "\" & サブフォルダ名 & "_" & 入力ファイル名
         Else    'ファイル名はもとのまま。サブフォルダ名は無視する
            On Error Resume Next
            'fso.MoveFile 引数 Destination に指定したファイルが存在する場合のエラー回避
            '移動先に同じファイル名が既に存在する場合に 実行時エラー58 となります
            ファイルシステムオブジェクト.MoveFile _
            入力ファイルフルパス, 現在のパス & "\"
         End If
'         Stop

      Next '★ファイル
   Next '★フォルダ
        
   Set ファイルシステムオブジェクト = Nothing
   
   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub
チェックボックスの書式
解説：
　フォームコントロールのチェックボックス
https://tonari-it.com/excel-form-checkbox/
エクセルに挿入できるチェックボックスは、「フォームコントロールのチェックボックス」と「ActiveXコントロールのチェックボックス」の2種類があります。
　「フォームコントロールのチェックボックス」の方が設定が分かりやすく、私の推奨です。 設定方法は、コントロールを右クリック → 「コントロールの書式設定」をクリックします。
「コントロールの書式設定」というウインドウが開くので、「コントロール」タブの「リンクするセル」に、連動させたいセルを指定します。


この種類の目次に戻る↑　索引へ↓　トップページに戻る


ホームページのトップに戻る