【VBA】FSOを使用してファイルの読み・書き・追記を行う

<機能>

FSO(FileSystemObject)を使ってファイルの読み・書き・追記を行うサンプルです

(1)ファイルにテキストを書き込む

(2)ファイルにテキストを追記する

(3)ファイルからテキストを読み込む

(4)フォルダを作成する

(5)ファイルを別フォルダにリネームしてコピーする

(6)ファイルをワイルドカードを使用して別フォルダにコピーする

(7)ファイルを削除する

 

<実行イメージ>

上記(1)〜()実行後のイメージです

()()  ファイル書き込み・追記を行います

(3)  追記を行ったファイルを読み込み結果をシートに出力します

()()  フォルダを作成し作成したファイルを100回コピーします

()  100回コピーされたファイルを別フォルダにワイルドカードを使用してコピーします

(7)  コピーしたファイルからファイル末尾に不可した数値が10の倍数のファイルを削除します

VBA,FSO,実行イメージ,

VBA,FSO,読み込みデータをシートに表示,

 

<動作検証&開発環境>
Microsoft Office 2016

 

<使い方>

(1)参照設定を行います

[Alt]+[F11]でVBE(VBAエディター)を表示します

メニューの[ツール(T)]から[参照設定(R)]を選択します

Microsoft Scripting Runtimeをチェックして[OK]を押下してください

VBA,FSO,参照設定,MicrosoftScriptingRuntime,

これによりForReading / TristateFalseなどの定数が使用できるようになります

 

(2)標準モジュールを追加してソースを貼り付けます

(3)「FSOでファイルを操作する」 プロシージャを実行します

 

Option Explicit
'/*********************************************
'/ ファイル操作メイン処理
'/ このプロシージャをコールする
'/*********************************************

Public Sub FSOでファイルを操作する()
    Dim strfile As String
    Dim strfolder As String, strfolder2 As String
    Dim strtxt As String, strbuf() As String
    Dim i As Integer
   
    '//データは横浜市の区ごとの総人口と男女別人口
    strtxt = "横浜市全体,3724844,1855985,1868859" & vbCrLf & _
            "鶴見区,285356,147650,137706" & vbCrLf & _
            "神奈川区,238966,121769,117197" & vbCrLf & _
            "西区,98532,49850,48682" & vbCrLf & _
            "中区,148312,78087,70225" & vbCrLf & _
            "南区,194827,97006,97821" & vbCrLf & _
            "保土ヶ谷区,205493,102381,103112" & vbCrLf & _
            "磯子区,166229,81827,84402" & vbCrLf & _
            "金沢区,202229,99167,103062" & vbCrLf & _
            "港北区,344172,174460,169712" & vbCrLf & _
            "戸塚区,275283,135271,140012" & vbCrLf & _
            "港南区,215736,106126,109610" & vbCrLf & _
            "旭区,247144,120168,126976" & vbCrLf & _
            "緑区,180366,89002,91364" & vbCrLf & _
            "瀬谷区,124560,60889,63671" & vbCrLf & _
            "栄区,122171,59729,62442" & vbCrLf & _
            "泉区,154025,75460,78565" & vbCrLf & _
            "青葉区,309692,151182,158510" & vbCrLf & _
            "都筑区,211751,105961,105790" & vbCrLf
    '//ファイルパス
    strfile = ThisWorkbook.Path & "¥fsotest.txt"
   
    '//――――――――――――――――――――――
    '//(1)ファイルにテキストを書き込む
    If Not WriteUsingFSO(strtxt, strfile) Then
        MsgBox "ファイル書き込み(WriteUsingFSO)に失敗しました", vbCritical
        Exit Sub
    End If
   
    '//――――――――――――――――――――――
    '//(2)ファイルにテキストを追記する
    If Not AppendUsingFSO(strtxt, strfile) Then
        MsgBox "ファイルへの追記(AppendUsingFSO)に失敗しました", vbCritical
        Exit Sub
    End If
       
    '//――――――――――――――――――――――
    '//(3)ファイルからテキストを読み込む
    If Not ReadUsingFSO(strbuf, strfile) Then
        MsgBox "ファイル読み込み(ReadUsingFSO)に失敗しました", vbCritical
        Exit Sub
    End If
    '//結果表示
    For i = 0 To UBound(strbuf)
        'セル内折り返しを解除
        Range("A" & CStr(i + 1)).WrapText = False
        '読み込みデータを出力
        Range("A" & CStr(i + 1)).Value = strbuf(i)
    Next
   
    '//――――――――――――――――――――――
    '//(4)フォルダを作成する
    strfolder = ThisWorkbook.Path & "¥" & Format(Now, "yyyymmddhhmmss")
    If Not CreateDirUsingFSO(strfolder) Then
        MsgBox "フォルダ作成(CreateDirUsingFSO)に失敗しました", vbCritical
        Exit Sub
    End If
    '//――――――――――――――――――――――
    '//(5)ファイルを別フォルダにリネームしてコピー
    If Not CopyFileUsingFSO(strfile, strfolder) Then
        MsgBox "ファイルコピー(CopyFileUsingFSO)に失敗しました", vbCritical
        Exit Sub
    End If
   
    '//――――――――――――――――――――――
    '//(6)ファイルをワイルドカードを使用して別フォルダにコピー
    '//先に移動先フォルダを作成する(フォルダ名が重複しないように1秒Wait)
    Application.Wait Now + TimeValue("0:00:01")
    strfolder2 = ThisWorkbook.Path & "¥" & Format(Now, "yyyymmddhhmmss")
    If Not CreateDirUsingFSO(strfolder2) Then
        MsgBox "フォルダ作成(CreateDirUsingFSO2)に失敗しました", vbCritical
        Exit Sub
    End If
    '//strfolderに含まれるすべての".txt"ファイルをstrfolder2にコピーする
    If Not CopyFileUsingFSO2(strfolder, strfolder2) Then
        MsgBox "ファイルコピー(CopyFileUsingFSO2)に失敗しました", vbCritical
        Exit Sub
    End If
   
    '//――――――――――――――――――――――
    '//(7)ファイルを削除する
    '//strfolder2から指定ファイルを削除する
    If Not DeleteFileUsingFSO(strfolder2) Then
        MsgBox "ファイル削除(DeleteFileUsingFSO)に失敗しました", vbCritical
        Exit Sub
    End If
   
End Sub
'/*********************************************
'/ ファイル書き込み(FSOでテキストファイルに書き込み)
'/  stxt : 書き込みテキスト
'/  sfil : 書き込みファイル
'/*********************************************

Private Function WriteUsingFSO(ByVal stxt As String, ByVal sfil As String) As Boolean
    On Error GoTo LblError
    Dim myfso As Object, writefso As Object
   
    '//初期値Falseを設定
    WriteUsingFSO = False
   
    '//FSOオブジェクトを取得する
    Set myfso = CreateObject("Scripting.FileSystemObject")
    '//TextStreamオブジェクトを[上書き]・[ASCIIファイル]で作成(詳細はDeveloperNetwork参照)
    Set writefso = myfso.CreateTextFile(sfil, True, False)
    '//引数は省略可能なので以下でもよい
    '//Set writefso = myfso.CreateTextFile(sfil)
   
    '//ファイルがなければ作成、あれば上書きとなる
    writefso.Write stxt
    '//TextStreamオブジェクトを閉じる
    writefso.Close
    WriteUsingFSO = True
    Exit Function
   
LblError:
    '//Falseで戻る
End Function
'/*********************************************
'/ ファイルへ追記(FSOでテキストファイルに追記する)
'/  stxt : 追記するテキスト
'/  sfil : 追記ファイル
'/*********************************************

Private Function AppendUsingFSO(ByVal stxt As String, ByVal sfil As String) As Boolean
    On Error GoTo LblError
    Dim myfso As Object, appendfso As Object
   
    '//初期値Falseを設定
    AppendUsingFSO = False
   
    '//FSOオブジェクトを取得する
    Set myfso = CreateObject("Scripting.FileSystemObject")
    '//TextStreamオブジェクトを[ファイルの最後に追記]・[ファイルを作成しない]・[ASCIIファイル]で作成(詳細はDeveloperNetwork参照)
    Set appendfso = myfso.OpenTextFile(sfil, ForAppending, False, TristateFalse)
   
    '//ファイルの最後に追記する
    appendfso.Write stxt
    '//TextStreamオブジェクトを閉じる
    appendfso.Close
    AppendUsingFSO = True
    Exit Function
   
LblError:
    '//Falseで戻る
End Function
'/*********************************************
'/ ファイル読み込み(FSOでテキストファイルから読み込み)
'/  sbuf : 読み込みテキスト(参照渡し)
'/  sfil : 読み込みファイル
'/*********************************************

Private Function ReadUsingFSO(ByRef sbuf() As String, ByVal sfil As String) As Boolean
    On Error GoTo LblError
    Dim myfso As Object, readfso As Object
    Dim strwk As String
   
    '//初期値Falseを設定
    ReadUsingFSO = False
    ReDim sbuf(0)
    sbuf(0) = ""
   
    '//FSOオブジェクトを取得する
    Set myfso = CreateObject("Scripting.FileSystemObject")
    '//TextStreamオブジェクトを[読み取り専用]・[ファイルを作成しない]・[ASCIIファイルとして開く]で作成(詳細はDeveloperNetwork参照)
    Set readfso = myfso.OpenTextFile(sfil, ForReading, False, TristateFalse)
    '//引数は省略可能なので以下でもよい
    '//Set readfso = myfso.OpenTextFile(sfil,ForReading)
   
    '//TextStreamファイル全体を読み込む(改行コードが読み込めない)
    '//sbuf = readfso.ReadAll
    '//TextStreamファイルを1行ずつ読み込む
    Do While readfso.AtEndOfStream <> True
        strwk = readfso.ReadLine
        If sbuf(UBound(sbuf)) <> "" Then
            ReDim Preserve sbuf(UBound(sbuf) + 1)
            sbuf(UBound(sbuf)) = ""
        End If
        sbuf(UBound(sbuf)) = strwk
    Loop
   
    '//TextStreamオブジェクトを閉じる
    readfso.Close
    ReadUsingFSO = True
    Exit Function
   
LblError:
    '//Falseで戻る
End Function
   
'/*********************************************
'/ フォルダ作成(FSOでフォルダを作成)
'/  sfol : 作成フォルダパス
'/*********************************************

Private Function CreateDirUsingFSO(ByVal sfol As String) As Boolean
    On Error GoTo LblError
    Dim myfso As Object
   
    '//初期値Falseを設定
    CreateDirUsingFSO = False
   
    '//FSOオブジェクトを取得する
    Set myfso = CreateObject("Scripting.FileSystemObject")
    '//フォルダの存在チェック
    If myfso.FolderExists(sfol) Then GoTo LblError
   
    '//フォルダを作成する
    myfso.CreateFolder sfol
    CreateDirUsingFSO = True
    Exit Function
   
LblError:
    '//Falseで戻る
End Function
'/*********************************************
'/ ファイルコピー(FSOでファイルをリネームしてコピー)
'/  sfil : コピー元ファイル
'/  sfol : コピー先フォルダ
'/*********************************************

Private Function CopyFileUsingFSO(ByVal sfil As String, ByVal sfol As String) As Boolean
    On Error GoTo LblError
    Dim myfso As Object
    Dim newfil As String, i As Integer
    Dim strtmp As String
   
    '//初期値Falseを設定
    CopyFileUsingFSO = False
   
    '//FSOオブジェクトを取得する
    Set myfso = CreateObject("Scripting.FileSystemObject")
   
    '//サンプルとして100回コピーする
    strtmp = Right(sfil, Len(sfil) - InStrRev(sfil, "¥"))
    For i = 1 To 100
       
        newfil = sfol & "¥" & Left(strtmp, InStrRev(strtmp, ".") - 1) & "_" & Format(CStr(i), "000") & ".txt"
        'ファイルを指定フォルダにリネームしてコピー
        '[コピー元]・[コピー先]・[ファイルが存在する場合は上書き]でコピー(詳細はDeveloperNetwork参照)
        myfso.CopyFile sfil, newfil, True
    Next
    CopyFileUsingFSO = True
    Exit Function
   
LblError:
    '//Falseで戻る
End Function
'/*********************************************
'/ ファイルコピー(FSOでワイルドカードを使用してファイルを一括コピー)
'/ ワイルドカードが使用できるのはファイル名のみです
'/  sfol1 : コピー元ファイル
'/  sfol2 : コピー先フォルダ
'/*********************************************

Private Function CopyFileUsingFSO2(ByVal sfol1 As String, ByVal sfol2 As String) As Boolean
    On Error GoTo LblError
    Dim myfso As Object
   
    '//初期値Falseを設定
    CopyFileUsingFSO2 = False
   
    '//FSOオブジェクトを取得する
    Set myfso = CreateObject("Scripting.FileSystemObject")
   
    '//[コピー元]・[コピー先]・[ファイルが存在する場合は上書き]でコピー
    '//対象は拡張子が".txt"のファイル
    myfso.CopyFile sfol1 & "¥*.txt", sfol2 & "¥", True
    '//ファイルを移動する場合はMoveFileを使用する
    '//myfso.MoveFile sfol1 & "¥*.txt", sfol2 & "¥"
    CopyFileUsingFSO2 = True
    Exit Function
   
LblError:
    '//Falseで戻る
End Function
'/*********************************************
'/ ファイル削除(FSOで指定ファイルを削除)
'/ サンプルとしてファイル名末尾の3桁の数値が10の倍数のファイルを削除
'/  sfol : ファイル格納フォルダ
'/*********************************************

Private Function DeleteFileUsingFSO(ByVal sfol As String) As Boolean
    On Error GoTo LblError
    Dim myfso As Object
    Dim strbuf As String, strtmp As String
   
    '//初期値Falseを設定
    DeleteFileUsingFSO = False
   
    '//FSOオブジェクトを取得する
    Set myfso = CreateObject("Scripting.FileSystemObject")
    '//フォルダ内のファイルを取得して対象なら削除する
    strbuf = Dir(sfol & "¥*.txt", vbNormal)
    Do While strbuf <> ""
        'ファイル末尾の3桁の数値を取得
        strtmp = Replace(Right(strbuf, Len(strbuf) - InStrRev(strbuf, "_")), ".txt", "")
        '10の倍数か判定
        If IsNumeric(strtmp) = False Then GoTo LblNextRecord
        If (CInt(strtmp) Mod 10) = 0 Then
            'ファイルを削除(読み取り専用属性ファイルを削除)(詳細はDeveloperNetwork参照)
            myfso.DeleteFile sfol & "¥" & strbuf, True
        End If
       
LblNextRecord:
        strbuf = Dir()
    Loop
   
    '//フォルダを作成する
    DeleteFileUsingFSO = True
    Exit Function
   
LblError:
    '//Falseで戻る
End Function

よろしければポチッと押してください


<< | 2/58PAGES | >>

selected entries

categories

calendar

S M T W T F S
  12345
6789101112
13141516171819
20212223242526
2728293031  
<< January 2019 >>

profile

others

archives