More than 1 year has passed since last update.

ExcelVBA 　ファイル関連

ExcelVBA

Last updated at 2022-09-11Posted at 2022-09-03

自分用のメモなので、形は整ってないです。

フォルダが存在するか確認する

パスの文字列に " "、"\"、"/"、"." を指定すると異常な動作になるので、入力チェックで拒否しないと駄目

Sub aaa()

Dim path As String
path = "C:\work"

' Dir関数での方法
If Dir(path, vbDirectory) = "" Then
  Debug.Print "フォルダは存在しない"
Else
  Debug.Print "フォルダは存在する"
End If


' FSOでの方法
Dim xFSO As Object
Set xFSO = CreateObject("Scripting.FileSystemObject")

If xFSO.FolderExists(path) = True Then
  Debug.Print "フォルダは存在する"
Else
  Debug.Print "フォルダは存在しない"
End If

Debug.Print "----------------------------"

'※パスの文字列の内容によっては、エラーになったり変な判定になるので注意が必要

path = " "  '半角スペース1つ
'Debug.Print Dir(path, vbDirectory) = ""  'このコードはエラーになる

path = "\"
Debug.Print Dir(path, vbDirectory) = ""  'False
'このコードはエラーにはならないが、"\"というパスは存在しないはずなのに、存在するという判定になる

path = "/"
Debug.Print Dir(path, vbDirectory) = ""  'False
'このコードはエラーにはならないが、"/"というパスは存在しないはずなのに、存在するという判定になる

path = "."
Debug.Print Dir(path, vbDirectory) = ""  'False
'このコードはエラーにはならないが、"."というパスは存在しないはずなのに、存在するという判定になる

Debug.Print "----------------------------"

path = " "
Debug.Print xFSO.FolderExists(path)  'False　正しい判定  これはエラーにならない

path = "\"
Debug.Print xFSO.FolderExists(path)  'True　間違った判定

path = "/"
Debug.Print xFSO.FolderExists(path)  'True　間違った判定

path = "."
Debug.Print xFSO.FolderExists(path)  'True　間違った判定

Set xFSO = Nothing

'※FSOのほうがいいと思うが、完璧ではない
' " "、"\"、"/"、"." は入力チェックで拒否しないと駄目

End Sub

ファイルが存在するか確認する

パスの文字列に " "、"\"、"/"、"." を指定すると、Dir関数は異常な動作になる。FSOを使う場合でも、" "、"\"、"/"、"."は入力チェックで拒否すべき

Sub bbb()

Dim path As String
path = "C:\work\aaa.txt"

' Dir関数での方法
If Dir(path) = "" Then
  Debug.Print "ファイルは存在しない"
Else
  Debug.Print "ファイルは存在する"
End If


' FSOでの方法
Dim xFSO As Object
Set xFSO = CreateObject("Scripting.FileSystemObject")

If xFSO.FileExists(path) = True Then
  Debug.Print "ファイルは存在する"
Else
  Debug.Print "ファイルは存在しない"
End If

Debug.Print "----------------------------"

'※パスの文字列の内容によっては、エラーになったり変な判定になるので注意が必要

path = " "  '半角スペース1つ
'Debug.Print Dir(path) = ""  'このコードはエラーになる

path = "\"
Debug.Print Dir(path) = ""  'False
'このコードはエラーにはならないが、"\"というパスは存在しないはずなのに、存在するという判定になる

path = "/"
Debug.Print Dir(path) = ""  'False
'このコードはエラーにはならないが、"/"というパスは存在しないはずなのに、存在するという判定になる

path = "."
Debug.Print Dir(path) = ""  'False
'このコードはエラーにはならないが、"."というパスは存在しないはずなのに、存在するという判定になる

Debug.Print "----------------------------"

path = " "
Debug.Print xFSO.FileExists(path)  'False　正しい判定  これはエラーにならない

path = "\"
Debug.Print xFSO.FileExists(path)  'False　正しい判定

path = "/"
Debug.Print xFSO.FileExists(path)  'False　正しい判定

path = "."
Debug.Print xFSO.FileExists(path)  'False　正しい判定

Set xFSO = Nothing

'※FSOなら問題は無さそうだが、完璧かどうかはわからない
' " "、"\"、"/"、"." は入力チェックで拒否しないと駄目

End Sub

ファイルのフルパスから、フォルダパスとファイル名を取得する

Dim fullPath As String
Dim pathStr As String
Dim filename As String
Dim xFSO As FileSystemObject

fullPath = "C:\work\AAA\BBB\BBB.xlsm"

If Dir(fullPath) <> "" Then
    filename = Dir(fullPath)                     ' ファイル名を取得(ファイルが存在しないと、Dir関数は""を返すので注意)
    pathStr = Replace(fullPath, filename, "")    ' ファイル名を除いたパスを取得
    MsgBox "ファイル名： " & filename
    MsgBox "パス： " & pathStr
Else
    MsgBox "ファイルが存在しません"
End If


' FSOでの方法
' FSOの場合は、存在しないファイルでもファイル名・パスを取得できてしまうので、ちょっと危険かも
Set xFSO = New FileSystemObject

filename = xFSO.GetFileName(fullPath)
pathStr = xFSO.GetParentFolderName(fullPath)
MsgBox "ファイル名： " & filename
MsgBox "パス： " & pathStr

Set xFSO = Nothing

相対パスでの指定

' 自ブックの下の階層の相対パス
If Dir(ThisWorkbook.Path & "\ccc\ccc.txt") = "" Then
    MsgBox "ファイルは存在しません"
Else
    MsgBox "ファイルは存在します"
End If

' 自ブックの上の階層の相対パス
If Dir("..\..\work.txt") = "" Then
    MsgBox "ファイルは存在しません"
Else
    MsgBox "ファイルは存在します"
End If


' FSOで相対パスから絶対パスを取得する
Dim xFSO As FileSystemObject

Set xFSO = New FileSystemObject
MsgBox xFSO.GetAbsolutePathName("..\")
Set xFSO = Nothing

テキストファイルを読み込む　　Shift-JISのファイルのみ

Sub ooo()
' ※このコードは、Shift-JISのテキストファイルを前提にしている。他の文字コードだと文字化けする
'UTF-8等を扱う場合は、ADODB.Streamを使うのがいい

Dim filePath As String
filePath = "C:\work\shiftJIS.txt"

If Dir(filePath) = "" Then   ' ファイルが存在しない場合
  Exit Sub
End If

' ※古い方法。確実だが効率悪い?
Dim fileNumber As Long   ' 開くテキストファイルのファイル番号
fileNumber = FreeFile
' 使用可能なファイル番号を取得し、それをファイル番号として使う
'通常は1が取得されるが、異常終了などで別の番号になっていることもある


Open filePath For Input As fileNumber
' filePathのテキストファイルを、読み込みモード(Input)、ファイル番号fileNumberで開く
'画面上ではそのファイルは表示されない
' Outputで書き込みモード、Appendで末尾に追加モード

Dim dataStr As String

Do Until EOF(fileNumber)  ' ファイル番号fileNumberのファイルの最後まで
  Line Input #fileNumber, dataStr  ' 1行ずつ読込み
  Debug.Print dataStr
Loop

Close #fileNumber  ' ファイル番号fileNumberのファイルを閉じる
Close  ' 現在開いているファイルを全て閉じる(慎重にいくならこれ？)

Debug.Print "-------------------------"


' ※FSOを使う方法。特に問題なければこれで
Dim xFSO As Object
Dim ts As TextStream    ' テキストストリーム

Set xFSO = CreateObject("Scripting.FileSystemObject")
Set ts = xFSO.OpenTextFile(filePath, ForReading)  ' 読み込みモードで開く

Do Until ts.AtEndOfStream  ' ファイルの最後まで
  dataStr = ts.ReadLine    '1行ずつ読み込み
  Debug.Print dataStr
Loop

ts.Close  ' ストリームを閉じる
Set ts = Nothing

Debug.Print "-------------------------"

' ※FSOでファイルの内容を一括取得も可能
Set ts = xFSO.OpenTextFile(filePath, ForReading)  ' 読み込みモードで開く

Do Until ts.AtEndOfStream
  dataStr = ts.ReadAll
  Debug.Print dataStr
Loop

ts.Close
Set ts = Nothing
Set xFSO = Nothing

End Sub

テキストファイルに書き込む　　Shift-JISのみ

Sub ghghg()
' ※このコードは、Shift-JISのテキストファイルを前提にしている。他の文字コードだと文字化けする
'UTF-8等を扱う場合は、ADODB.Streamを使うのがいい

Dim filePath As String   ' 出力用のテキストファイルのパス
Dim fileNumber As Long

filePath = "C:\work\shiftJIS.txt"

If Dir(filePath) = "" Then  ' 出力用ファイルが存在しない場合
  Exit Sub
End If

' ※古い方法。確実だが効率悪い?
fileNumber = FreeFile   ' ファイル番号を、現在使用可能な番号に設定
Open filePath For Output As #fileNumber
' 出力モード(書き込みモード)、ファイル番号fileNumberでテキストファイルを開く

Print #fileNumber, "aaaaaa"   ' テキストファイルに出力
Print #fileNumber, "0123456"
Print #fileNumber, "あああああ"
Print #fileNumber, "アアアアアア"

Close #fileNumber     ' ファイルを閉じる



' ※FSOを使う方法。特に問題なければこれで
Dim xFSO As Object
Dim ts As TextStream    ' テキストストリーム

Set xFSO = CreateObject("Scripting.FileSystemObject")

filePath = "C:\work\new.txt"   ' 今回は新規ファイルのパスを指定する

Set ts = xFSO.CreateTextFile(FileName:=filePath, Overwrite:=True)
' 書き込みモードで開く。Overwrite:=Trueにすると、同名ファイルがあっても上書きする

ts.WriteLine "BBBBBB"   ' テキストファイルに書込み
ts.WriteLine "７８９４５６１２３０"
ts.WriteLine "日本語英語中国語"

ts.Close    ' ストリームを閉じる
Set ts = Nothing
Set xFSO = Nothing

End Sub

UTF-8のテキストファイルを読み込む　　ADODB.Streamを使用

Dim xStream As Object
Set xStream = New ADODB.Stream
'事前バインディング　Microsoft ActiveX Data Objects #.# Library への参照が必要

'Set xStream = CreateObject("ADODB.Stream")
'実行時バインディング。参照設定の必要なし
Dim filePath As String
Dim dataStr As String
Dim xRow As Long

filePath = "C:\work\aaa.txt"   ' UTF-8のテキストファイル
xRow = 1

With xStream
  .Charset = "UTF-8"   ' 文字コードにUTF-8を指定
  .Open
  .LoadFromFile filePath

  Do Until .EOS  ' ストリームの最後まで
    dataStr = .ReadText(-2)
    ' ReadText(-2) で1行ずつ読込み。ReadText(-1)、もしくは引数無しだと全データを読み込む
    Cells(xRow, 1).Value = dataStr
    xRow = xRow + 1
  Loop
  .Close  ' ストリームを閉じる
  
End With
Set xStream = Nothing

UTF-8でテキストファイルに書き込む　　ADODB.Streamを使用

'上書きで書き込み
Sub www()

Dim xStream As Object
Set xStream = New ADODB.Stream
'事前バインディング　Microsoft ActiveX Data Objects #.# Library への参照が必要

'Set xStream = CreateObject("ADODB.Stream")
'実行時バインディング。参照設定の必要なし

Dim filePath As String

filePath = "C:\work\aaa.txt"

With xStream
  .Charset = "UTF-8"   ' 文字コードにUTF-8を指定
  .Open
  .WriteText "あいうえお", 1
  ' 1行単位で書込み。既存のテキストに上書きする形になる
  '第2引数に「1」を指定すると行末に改行を付与する。「0」か省略で改行なし
  
  .WriteText "ACDE", 1
  .WriteText "日本語", 1
  .WriteText "012345"
  .SaveToFile filePath, 2
  ' ファイルに書込み。第2引数に「2」を指定すると、ファイルが存在しない場合は作成して書込み。存在する場合は上書き
  ' 第2引数に「1」を指定すると、ファイルが存在しない場合は作成して書込み。存在する場合はエラーになる
  .Close  ' ストリームを閉じる
End With

Set xStream = Nothing
End Sub


'追記の形で書き込み
Sub ttttt()

Dim xStream As Object
Dim filePath As String

Set xStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With xStream
  .Charset = "UTF-8"
  .Open
  .LoadFromFile filePath
  .ReadText                   'これでStreamに既存のテキストの内容を読み込む
  .WriteText "", 1            'これは改行を入れるだけ
  .WriteText "あいうえお", 1
  .WriteText "ACDE", 1
  .WriteText "日本語", 1
  .WriteText "012345"
  .SaveToFile filePath, 2
  .Close
End With

Set xStream = Nothing
End Sub

UTF-8、BOM無しでテキストファイルに書き込む

Sub bbb()

Dim xStream As Object
Set xStream = New ADODB.Stream
'事前バインディング　Microsoft ActiveX Data Objects #.# Library への参照が必要

'Set xStream = CreateObject("ADODB.Stream")
'実行時バインディング。参照設定の必要なし
Dim filePath As String
Dim dataStr As String
Dim arrByte() As Byte
Dim xRow As Long

filePath = "C:\work\aaa.txt"    ' UTF-8のテキストファイル
xRow = 1

With xStream
  .Charset = "UTF-8"   ' 文字コードにUTF-8を指定
  .Open

  Do Until xRow > 10  ' 10行目まで
    dataStr = Cells(xRow, 1).Value
    .WriteText dataStr, 1
    ' テキストファイルに書込み。第二引数に1を指定すると、行の末尾に改行を入れる(0か省略で改行なし)
    xRow = xRow + 1
  Loop
  
  ' BOMを削除するための処理
  .Position = 0         '位置を先頭に設定
  .Type = adTypeBinary  'バイナリ形式にする
  .Position = 3         '3バイト分移動。BOMは先頭の3バイトのデータなので、それを削除するため
  arrByte = .Read       ' テキストの内容を再読込みして、それを3バイトずらして書き込む形
  .Position = 0
  .Write arrByte
  .SetEOS               '位置を末尾に設定
  .SaveToFile filePath, 2
  ' テキストファイルを保存する。引数に1を指定すると、同名ファイルがすでに存在する場合にエラーになる。2を指定すると、強制的に上書きする
  .Close  ' ストリームを閉じる
End With
Set xStream = Nothing

End Sub

CSVファイルを読み込んで、指定のセルからデータをセットする

' ※このコードは、Shift-Jisのテキストファイルを前提にしている

Dim xFSO As New FileSystemObject
Dim ts As TextStream    ' テキストストリーム
Dim filePath As String
Dim dataStr As String
Dim dataArray() As String   ' 1行分のCSVファイルのデータを、区切り文字で分割して格納する配列
Dim xRow As Long
Dim xColumn As Long
Dim i As Long

filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\Shift_JIS.csv"
Set ts = xFSO.OpenTextFile(filePath, ForReading)  ' 読み込みモードで開く

' セルA1からデータを入れていく
xRow = 1
xColumn = 1

Do Until ts.AtEndOfStream  ' ファイルの最後まで
    dataStr = ts.ReadLine
    dataArray = Split(dataStr, ",")
    ' CSVファイルの1行分のデータを、区切り文字で分割して配列に格納。今回はカンマ区切り
    
    For i = 0 To UBound(dataArray)
        Cells(xRow, xColumn).Value = dataArray(i)
        xColumn = xColumn + 1
    Next i
    
    Erase dataArray
    xColumn = 1
    xRow = xRow + 1
Loop

ts.Close  ' ストリームを閉じる
Set ts = Nothing
Set xFSO = Nothing

UTF-8、BOMありのテキストファイルを、BOMの削除だけをする

BOM無しのファイルに対して実行しても、特に影響は無いようだが

Sub ccc()

Dim xStream As Object
Set xStream = CreateObject("ADODB.Stream")
Dim filePath As String
Dim arrByte() As Byte

filePath = "C:\work\aaa.txt"

With xStream
  .Charset = "UTF-8"
  .Open
  .LoadFromFile filePath  '内容を読み込み。ここで読み込んでおかないとエラーになるらしい
  
  ' BOMを削除するための処理
  .Position = 0         '位置を先頭に設定
  .Type = adTypeBinary  'バイナリ形式にする
  .Position = 3         '3バイト分移動。BOMは先頭の3バイトのデータなので、それを削除するため
  arrByte = .Read       ' テキストの内容を再読込みして、それを3バイトずらして書き込む形
  .Position = 0
  .Write arrByte
  .SetEOS               '位置を末尾に設定
  .SaveToFile filePath, 2  '上書きモードで保存
  .Close
End With
Set xStream = Nothing

'※BOM無しのファイルに対して実行しても、特に影響は無いみたい

End Sub

UTF-8のCSVファイルを読み込んで、指定のセルからデータをセットする

Dim xStream As New ADODB.Stream   ' ADOのストリーム
Dim filePath As String
Dim dataStr As String
Dim dataArray() As String   ' 1行分のCSVファイルのデータを、区切り文字で分割して格納する配列
Dim xRow As Long
Dim xColumn As Long
Dim i As Long

filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\UTF-8.csv"

xRow = 2
xColumn = 3
' セルB3からデータをセットする

With xStream
    .Charset = "UTF-8"   ' 文字コードにUTF-8を指定
    .Open
    .LoadFromFile filePath

    Do Until .EOS    ' ストリームの最後まで
        dataStr = .ReadText(-2)
        ' ReadText(-2) で1行ずつ読込み。ReadText(-1)、もしくは引数無しだと全データを読み込む
        
        dataArray = Split(dataStr, ",")
        ' CSVファイルの1行分のデータを、区切り文字で分割して配列に格納。今回はカンマ区切り
        
        For i = 0 To UBound(dataArray)
            Cells(xRow, xColumn).Value = dataArray(i)
            xColumn = xColumn + 1
        Next i
        
        Erase dataArray
        xColumn = 3
        xRow = xRow + 1
    Loop
    
    .Close  ' ストリームを閉じる
    
End With

Set xStream = Nothing

ADODB.Streamでファイルの文字コードを指定する (UTF-8 Shift-JIS Unicode EUC)

Sub nnn()

'UTF-8       .Charset = "UTF-8"
'Shift-JIS   .Charset = "Shift-JIS"
'Unicode     .Charset = "Unicode"
'EUC         .Charset = "EUC-JP"

Dim xStream As Object
Dim filePath As String
Dim textStr As String

Set xStream = CreateObject("ADODB.Stream")

'UTF-8のテキスト
filePath = "C:\work\utf8.txt"
With xStream
  .Charset = "UTF-8"
'  .Charset = "utf-8"   これでもいい
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  Debug.Print "--------------------"
  Debug.Print .Charset
  Debug.Print "--------------------"
  Debug.Print textStr
  .Close
End With

'Shift-JISのテキスト
filePath = "C:\work\shiftJIS.txt"
With xStream
  .Charset = "Shift-JIS"
'  .Charset = "shift-jis"   これでもいい
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  Debug.Print "--------------------"
  Debug.Print .Charset
  Debug.Print "--------------------"
  Debug.Print textStr
  .Close
End With

'Unicodeのテキスト
filePath = "C:\work\unicode.txt"
With xStream
  .Charset = "Unicode"
'  .Charset = "unicode"   これでもいい
'  .Charset = "UNICODE"   これでもいい
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  Debug.Print "--------------------"
  Debug.Print .Charset
  Debug.Print "--------------------"
  Debug.Print textStr
  .Close
End With

'EUCのテキスト
filePath = "C:\work\EUC.txt"
With xStream
  .Charset = "EUC-JP"
'  .Charset = "euc-jp"   これでもいい
'  .Charset = "EUC"      これはエラーになる
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  Debug.Print "--------------------"
  Debug.Print .Charset
  Debug.Print "--------------------"
  Debug.Print textStr
  .Close
End With

Set xStream = Nothing
End Sub

選択しているセル範囲のデータを、UTF-8、BOM無しでCSVファイルとして書き込む

' ※ ADOを使うので、Microsoft ActiveX Data Objects #.# Library への参照が必要

Dim xStream As New ADODB.Stream   ' ADOのストリーム
Dim filePath As String
Dim dataStr As String
Dim firstRow As Long
Dim lastRow As Long
Dim firstColumn As Long
Dim lastColumn As Long
Dim xRow As Long
Dim xColumn As Long
Dim i As Long
Dim j As Long


filePath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\UTF-8.csv"

firstRow = Selection.Row  ' 選択しているセル範囲の先頭セルの行番号
lastRow = Selection.Row + Selection.Rows.Count - 1  ' 選択しているセル範囲の最後尾セルの行番号
firstColumn = Selection.Column
lastColumn = Selection.Column + Selection.Columns.Count - 1

With xStream
    .Charset = "UTF-8"   ' 文字コードにUTF-8を指定
    .Open

    dataStr = ""
    xRow = firstRow
    xColumn = firstColumn
    For i = firstRow To lastRow
        For j = firstColumn To lastColumn
        
            If xColumn = firstColumn Then   ' その行の、最初の列のデータの場合は、前にカンマを付与しない
                dataStr = dataStr & Cells(xRow, xColumn).Value
            Else
                dataStr = dataStr & "," & Cells(xRow, xColumn).Value
            End If
            xColumn = xColumn + 1
        
        Next j
            
        .WriteText dataStr, 1
        ' テキストファイルに書込み。第二引数に1を指定すると、行の末尾に改行を入れる(0か省略で改行なし)
        xColumn = firstColumn
        xRow = xRow + 1
        dataStr = ""
    Next i
    
    ' BOMを削除するための処理
    Dim var1 As Variant
    .Position = 0
    .Type = adTypeBinary
    .Position = 3        ' BOMは先頭の3バイトのデータなので、それを削除するため
    var1 = .Read()       ' テキストの内容を再読込みして、それを3バイトずらして書き込む形
    .Position = 0
    .Write var1
    .SetEOS       ' BOMを削除した分、後ろに不要なデータが残るので、それを捨てる処理らしい
    
    
    .SaveToFile filePath, 2
    ' テキストファイルを保存する。引数に1を指定すると、同名ファイルがすでに存在する場合にエラーになる。2を指定すると、強制的に上書きする
    
    .Close  ' ストリームを閉じる
    
End With

Set xStream = Nothing

UTF-8のテキストファイルを、Shift-JISに変換する

'文字コード変更
Sub mmm()

Dim xStream As Object
Dim filePath As String
Dim textStr As String

Set xStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With xStream
  .Charset = "UTF-8"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText   'UTF-8で読み込んだ内容を、textStrに格納しておく
  .Close
End With

With xStream
  .Charset = "Shift-JIS"
  .Open
'  .LoadFromFile filePath　　ここでこのコードを入れないように。結果がおかしくなる
  .WriteText textStr       'Shift-JISで書き込み
  .SaveToFile filePath, 2
  .Close
End With

Set xStream = Nothing

'Streamは読み込み時と書き込み時で、別々に用意したほうがいいかも
End Sub

カレントフォルダの取得・設定、カレントドライブの設定

MsgBox "カレントフォルダは：" & CurDir
' カレントフォルダを取得。カレントドライブのカレントフォルダになる。現在のカレントドライブはC:

ChDir "C:\work"    ' カレントフォルダを設定
MsgBox "変更後のカレントフォルダは：" & CurDir


MsgBox "Eドライブのカレントフォルダは: " & CurDir("E")
' Eドライブのカレントフォルダを取得

ChDir "E:\aaaa"  ' カレントフォルダを設定
MsgBox CurDir
' "C:\work" と表示される。Eドライブのカレントフォルダは変更したが、カレントドライブがC:のままなので、
' ドライブ指定なしでカレントフォルダを取得するとカレントドライブのカレントフォルダになる

ChDrive "E"   ' カレントドライブをE:に変更
MsgBox CurDir
' カレントドライブをE:に変更したので、"E:\aaaa"と表示される

フォルダ内のファイルを検索する(サブフォルダは含まない)

Dim fileName As String
Dim folderPath As String

folderPath = "C:\まとめ総合\ExcelVBA"

' Dir関数での方法
fileName = Dir(folderPath & "\" & "*.xls*")   ' 今回はエクセル形式ファイルを対象にする

Do While fileName <> ""
    Debug.Print fileName
    fileName = Dir()   ' これは決まった形。全てのファイルを検索してしまうと、""を返すらしい
Loop


'FSOでの方法。このやり方だと、現在開いているファイルも「~$ファイル名」の形で取得してしまう
Dim xFSO As New FileSystemObject
Dim xFile As File

With xFSO
    For Each xFile In .GetFolder(folderPath).Files
        If xFile.Name Like "*.xls*" Then
            Debug.Print xFile.Name
        End If
    Next xFile
End With

Set xFSO = Nothing

サブフォルダも含めて、フォルダ内のファイルを検索する

Sub aaa()

    Dim folderPath As String
    
    folderPath = "C:\まとめ総合\ExcelVBA\111"
    Call FileSearch(folderPath)
    
    
End Sub


Sub FileSearch(folderPath As String)   ' ファイル検索を実行する

    Dim xFSO As New FileSystemObject
    Dim xFolder As Folder
    Dim xFile As File
    
    For Each xFolder In xFSO.GetFolder(folderPath).SubFolders
    ' サブフォルダを取得する
        Call FileSearch(xFolder.path)
        ' 再帰処理でサブフォルダまで検索
    Next xFolder
    
    For Each xFile In xFSO.GetFolder(folderPath).Files
    ' ファイルを検索
        If xFile.Name Like "*.xls*" Then   ' エクセル型のファイルの場合
            Debug.Print xFile.path
        End If
    Next xFile
    
    
    Set xFSO = Nothing

End Sub

テキストファイルの文字コードを判定する関数の例

完璧ではない。文字コードの判定自体が難しいことみたい。参考程度に

Sub aaa()

Debug.Print fncGetCharset("C:\work\EUC.txt")         'EUC-JP        EUCのテキスト
Debug.Print fncGetCharset("C:\work\sijis.txt")       'Shift_JIS     SJISのテキスト
Debug.Print fncGetCharset("C:\work\unicode.txt")     'BINARY        Unicodeのテキスト
Debug.Print fncGetCharset("C:\work\unicodeBOM.txt")  'UTF-16 LE BOM UnicodeBOMありのテキスト
Debug.Print fncGetCharset("C:\work\utf8.txt")        'UTF-8         UTF-8のテキスト
Debug.Print fncGetCharset("C:\work\utf8BOM.txt")     'UTF-8 BOM     UTF-8BOMありのテキスト
Debug.Print fncGetCharset("C:\work\ascii.txt")       'UTF-8         ASCII文字のみのテキスト
Debug.Print fncGetCharset("C:\work\aaa.dll")         'BINARY        バイナリファイル
Debug.Print fncGetCharset("C:\work\aaa.accdb")       'BINARY        Accessファイル
Debug.Print fncGetCharset("C:\work\aaa.xlsx")        'BINARY        Excelファイル
Debug.Print fncGetCharset("C:\work\aaa.docx")        'UTF-8 BOM     Wordファイル
Debug.Print fncGetCharset("C:\work\aaa.bmp")         'UTF-8 BOM     BMPファイル

End Sub


'文字コードをリターンする
Function fncGetCharset(filePath As String) As String
  Dim i As Long
  
  Dim freeFileNumber As Long
  Dim lngFileLen As Long
  
  Dim arrByteFile() As Byte
  Dim b1 As Byte
  Dim b2 As Byte
  Dim b3 As Byte
  Dim b4 As Byte
  
  Dim lngSJIS As Long
  Dim lngUTF8 As Long
  Dim lngEUC As Long
  
  On Error Resume Next
  
  'ファイル読み込み
  lngFileLen = FileLen(filePath)
  ReDim arrByteFile(lngFileLen)
  If (Err.Number <> 0) Then
    fncGetCharset = "ファイル読込でエラー発生"
    Exit Function
  End If
  
  freeFileNumber = FreeFile()  '使用可能なファイル番号を取得
  Open filePath For Binary As #freeFileNumber
  Get #freeFileNumber, , arrByteFile
  Close #freeFileNumber
  If (Err.Number <> 0) Then
    fncGetCharset = "フリーファイル作成でエラー発生"
    Exit Function
  End If
  
  'BOMによる判断
  If (arrByteFile(0) = &HEF And arrByteFile(1) = &HBB And arrByteFile(2) = &HBF) Then
  fncGetCharset = "UTF-8 BOM"
  Exit Function
  ElseIf (arrByteFile(0) = &HFF And arrByteFile(1) = &HFE) Then
  fncGetCharset = "UTF-16 LE BOM"
  Exit Function
  ElseIf (arrByteFile(0) = &HFE And arrByteFile(1) = &HFF) Then
  fncGetCharset = "UTF-16 BE BOM"
  Exit Function
  End If
  
  'BINARY
  For i = 0 To lngFileLen - 1
  b1 = arrByteFile(i)
  If (b1 >= &H0 And b1 <= &H8) Or (b1 >= &HA And b1 <= &H9) Or (b1 >= &HB And b1 <= &HC) Or _
    (b1 >= &HE And b1 <= &H19) Or (b1 >= &H1C And b1 <= &H1F) Or (b1 = &H7F) Then
    fncGetCharset = "BINARY"
    Exit Function
  End If
  Next i
     
  'SJIS
  For i = 0 To lngFileLen - 1
  b1 = arrByteFile(i)
  If (b1 = &H9) Or (b1 = &HA) Or (b1 = &HD) Or (b1 >= &H20 And b1 <= &H7E) Or _
    (b1 >= &HB0 And b1 <= &HDF) Then
    lngSJIS = lngSJIS + 1
  Else
    If (i < lngFileLen - 2) Then
      b2 = arrByteFile(i + 1)
      If ((b1 >= &H81 And b1 <= &H9F) Or (b1 >= &HE0 And b1 <= &HFC)) And _
         ((b2 >= &H40 And b2 <= &H7E) Or (b2 >= &H80 And b2 <= &HFC)) Then
        lngSJIS = lngSJIS + 2
        i = i + 1
      End If
    End If
  End If
  Next i
     
  'UTF-8
  For i = 0 To lngFileLen - 1
    b1 = arrByteFile(i)
    If (b1 = &H9) Or (b1 = &HA) Or (b1 = &HD) Or (b1 >= &H20 And b1 <= &H7E) Then
      lngUTF8 = lngUTF8 + 1
    Else
      If (i < lngFileLen - 2) Then
      b2 = arrByteFile(i + 1)
        
        If (b1 >= &HC2 And b1 <= &HDF) And (b2 >= &H80 And b2 <= &HBF) Then
           lngUTF8 = lngUTF8 + 2
           i = i + 1
        Else
        
          If (i < lngFileLen - 3) Then
            b3 = arrByteFile(i + 2)
            If (b1 >= &HE0 And b1 <= &HEF) And (b2 >= &H80 And b2 <= &HBF) And (b3 >= &H80 And b3 <= &HBF) Then
              lngUTF8 = lngUTF8 + 3
              i = i + 2
            Else
            
              If (i < lngFileLen - 4) Then
                b4 = arrByteFile(i + 3)
                If (b1 >= &HF0 And b1 <= &HF7) And (b2 >= &H80 And b2 <= &HBF) And _
                  (b3 >= &H80 And b3 <= &HBF) And (b4 >= &H80 And b4 <= &HBF) Then
                  lngUTF8 = lngUTF8 + 4
                  i = i + 3
                End If
              End If
            End If
          End If
        End If
      End If
    End If
  Next i

  'EUC-JP
  For i = 0 To lngFileLen - 1
    b1 = arrByteFile(i)
    If (b1 = &H7) Or (b1 = 10) Or (b1 = 13) Or (b1 >= &H20 And b1 <= &H7E) Then
      lngEUC = lngEUC + 1
    Else
      If (i < lngFileLen - 2) Then
        b2 = arrByteFile(i + 1)
        If ((b1 >= &HA1 And b1 <= &HFE) And _
           (b2 >= &HA1 And b2 <= &HFE)) Or _
           ((b1 = &H8E) And (b2 >= &HA1 And b2 <= &HDF)) Then
           lngEUC = lngEUC + 2
           i = i + 1
        End If
      End If
    End If
  Next i
       
  '文字コード出現順位による判断
  If (lngSJIS <= lngUTF8) And (lngEUC <= lngUTF8) Then
    fncGetCharset = "UTF-8"
    Exit Function
  End If
  If (lngUTF8 <= lngSJIS) And (lngEUC <= lngSJIS) Then
    fncGetCharset = "Shift_JIS"
    Exit Function
  End If
  If (lngUTF8 <= lngEUC) And (lngSJIS <= lngEUC) Then
    fncGetCharset = "EUC-JP"
    Exit Function
  End If
  fncGetCharset = "該当なし"
  
End Function

文字コードがUnicodeのテキストファイルのBOMを削除する

Sub pppo()  'UnicodeBOM削除

Dim xStream As Object
Dim filePath As String
Dim arrByte() As Byte

Set xStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With xStream
  .charSet = "Unicode"
  .Open
  .LoadFromFile filePath
  ' BOMを削除するための処理
  .Position = 0
  .Type = adTypeBinary
  .Position = 2         'UnicodeのBOMのバイト数は2なので
  arrByte = .Read
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With

Set xStream = Nothing
End Sub

ファイルの属性を取得・設定する(フォルダも含める)

Dim pathStr As String

pathStr = "C:\まとめ総合\ExcelVBA"  ' フォルダのパスを指定

MsgBox GetAttr(pathStr) And vbDirectory   ' 属性値を求める

' 「16」が表示される。これはフォルダ・ドライブの属性数値が16なので、16と返る。フォルダではないパスを指定すると、「0」が返る
' 属性値を取得できるというよりは、GetAttr(pathStr) と And ** の比較をして、一致すれば属性数値を返し、違う場合は「0」を返る形
' 他の属性については調べて


pathStr = "C:\まとめ総合\ExcelVBA\aaa.xlsx"  ' ファイルのパスを指定

SetAttr pathStr, vbHidden + vbReadOnly  ' 属性値を「隠しファイル」かつ「読み取り専用」に設定

' ※FSOでも似たようなことが出来るが、どちらにしても使いにくい

UTF-8のテキストファイルの内容を変更し、さらにBOMの削除も実行する

結構面倒な手順になる　　全角英字を置換する場合は、トラブルが出るかも。不明な点が多い

Sub nnn()  '既存のファイルの内容を書き換える

Dim writeStream As Object           'ADODB.Streamとする
Dim deleteBOMStream As Object       'ADODB.Streamとする
Dim dataStr As String           '全てのテキストデータを一括で読み込んだ文字列
Dim arrByte() As Byte           'バイト文字列の配列
Dim filePath As String

Set writeStream = CreateObject("ADODB.Stream")
Set deleteBOMStream = CreateObject("ADODB.Stream")
Erase arrByte
filePath = "C:\work\aaa.txt"

'テキストの読み込み
With writeStream
  .charSet = "UTF-8"
  .Open
  .LoadFromFile filePath
  dataStr = .ReadText     '内容を全て読み込み。変換対象の文字列があるかの判定に使う
  .Close
End With

dataStr = Replace(dataStr, "a", "Z", , , 0)
'バイナリモード比較で、文字列の変換をする

'テキストの書き込み
With writeStream
  .charSet = "UTF-8"
  .Open
  .LoadFromFile filePath
  .WriteText dataStr, 1   '最後に改行文字(VBAの場合はCRLF)を入れる
  'よくわからないが、最後に改行文字を入れないとテキストの内容がおかしくなることがある
  .SaveToFile filePath, 2  '上書きモードで保存
  .Close
End With
    
'最後のCRLFの削除
With writeStream
  .charSet = "UTF-8"
  .Open
  .LoadFromFile filePath
  .Position = 0
  .Type = adTypeBinary
  arrByte = .Read    'バイナリ(バイト列)で読み込む
  ReDim Preserve arrByte(UBound(arrByte) - 2)  'CRLFの2バイト分だけ削除
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With
    
'BOM削除
With deleteBOMStream   'writeStreamは一度.SetEOSにしているので、別のStreamにしないとエラーになるようだ
  .charSet = "UTF-8"
  .Open
  .LoadFromFile filePath
  ' BOMを削除するための処理
  .Position = 0
  .Type = adTypeBinary
  .Position = 3
  arrByte = .Read
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With

Set writeStream = Nothing
Set deleteBOMStream = Nothing

'※※※※　　ただし、これでも全角の英字を置換した場合などは、テキストの最後に変なバイト文字列が入ることがある
'そこでさらに改良したのが、次のプロシージャ
  
End Sub



Sub rrr()  '既存のファイルを新規テキストファイルで上書きして書き換える

Dim xFSO As Object   '
Dim xCTF As Object   'FSOのCreateTextFileオブジェクトとする
Dim writeStream As Object
Dim deleteBOMStream As Object
Dim dataStr As String
Dim arrByte() As Byte
Dim filePath As String

Set xFSO = CreateObject("Scripting.FileSystemObject")
Set writeStream = CreateObject("ADODB.Stream")
Set deleteBOMStream = CreateObject("ADODB.Stream")
Erase arrByte
filePath = "C:\work\aaa.txt"

With writeStream
  .charSet = "UTF-8"
  .Open
  .LoadFromFile filePath
  dataStr = .ReadText
  .Close
End With

dataStr = Replace(dataStr, "ｂ", "亜", , , 0)
'全角の英数を置換対象にする

Set xCTF = xFSO.CreateTextFile(filePath, True)
'ここで既存のファイルを、新規テキストファイルとして上書きしてしまう
Set xCTF = Nothing

With writeStream
  .charSet = "UTF-8"
  .Open
  .LoadFromFile filePath
  .WriteText dataStr, 1
  .SaveToFile filePath, 2
  .Close
End With
    
With writeStream
  .charSet = "UTF-8"
  .Open
  .LoadFromFile filePath
  .Position = 0
  .Type = adTypeBinary
  arrByte = .Read
  ReDim Preserve arrByte(UBound(arrByte) - 2)
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With
    
With deleteBOMStream
  .charSet = "UTF-8"
  .Open
  .LoadFromFile filePath
  .Position = 0
  .Type = adTypeBinary
  .Position = 3
  arrByte = .Read
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With

Set writeStream = Nothing
Set deleteBOMStream = Nothing

'※※※※　これで完璧なのかどうかは不明
'新規ファイルで上書きしなくても、全角英字を正常に置換できることもあり、よくわからない
  
End Sub

ファイルのコピー

Dim motherPath As String    ' コピー元ファイルパス
Dim childPath As String     ' コピー先ファイルパス

motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\111\ABC.xlsx"

FileCopy motherPath, childPath
' motherPathを、childPathとしてコピーする。childPathと同じパスのファイルが存在する場合は、強制上書きする


motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\111\QQQ.xls"
FileCopy motherPath, childPath
' Excel2007ファイルを、Excel2003ファイルとしてコピー。Excel2003ファイルを開く時に警告が出るが、中身は問題なし?

motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\111\RRR.xlsm"
FileCopy motherPath, childPath
' マクロ無しブックを、マクロ有りブックとしてコピー。マクロ有りブックを開く時に警告が出て、開くことが出来ない


motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\bbb.xlsx"
If Dir(childPath) <> "" Then
    MsgBox "コピー先のパスのファイルはすでに存在しているので、コピーは中止します"
Else
    FileCopy motherPath, childPath
End If
' 強制上書きされるのを防ぐなら、このような方法かな


Dim xFSO As New FileSystemObject

motherPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
childPath = "C:\まとめ総合\ExcelVBA\DDD.xlsx"

xFSO.CopyFile motherPath, childPath
' FSOでの方法。こちらもコピー先パスと同じファイルがすでに存在する場合は、強制上書き

Set xFSO = Nothing

Unicodeのテキストファイルを、内容を書き換えてBOMも削除する

かなり面倒な手順だし、Unicodeのファイルはトラブルが多いみたい。必要になるなら、程度で

Private Sub ConvertUnicodeText()
  Dim xFSO As Object
  Dim readStream As Object        'ADODB.Streamとする　テキスト読み込み時のStream
  Dim writeStream As Object       'テキスト書き込み時のStream
  Dim deleteCRLFStream As Object  '末尾のCRLF削除時のStream
  Dim deleteBOMStream As Object   'BOM削除時のStream
  Dim xCTF As Object              'FSOのCreateTextFileオブジェクトとする
  Dim dataStr As String           '全てのテキストデータを一括で読み込んだ文字列
  Dim arrByte() As Byte
  Dim filePath As String
  
  Set xFSO = CreateObject("Scripting.FileSystemObject")
  Set readStream = CreateObject("ADODB.Stream")
  Set writeStream = CreateObject("ADODB.Stream")
  Set deleteCRLFStream = CreateObject("ADODB.Stream")
  Set deleteBOMStream = CreateObject("ADODB.Stream")
  
  filePath = "C:\work\aaa.txt"

  With readStream
    .Charset = "Unicode"
    .Open
    .LoadFromFile filePath
    dataStr = .ReadText     '内容を全て読み込み
    .Close
  End With
  
  dataStr = Replace(dataStr, "a", "Z", , , 0)
  'バイナリモード比較で、文字列の変換をする
    
  Set xCTF = xFSO.CreateTextFile(filePath, True)
  'ここで既存のファイルを、新規テキストファイルとして上書きしてしまう
  Set xCTF = Nothing

  With writeStream
    .Charset = "Unicode"
    .Open
    .LoadFromFile filePath
    .WriteText dataStr, 1           '最後に改行文字を入れて書き込み
    .SaveToFile filePath, 2  '上書きモードで保存
    .Close
  End With
  
  With deleteCRLFStream
    .Charset = "Unicode"
    .Open
    .LoadFromFile filePath
    .Position = 0
    .Type = adTypeBinary
    arrByte = .Read
    ReDim Preserve arrByte(UBound(arrByte) - 4)
    'Unicodeは後ろから4バイト削る。
    '※CRLFは2バイトなのだが、Unicodeのときに限り4バイトにしないと、最後におかしな改行文字が入ってしまう
    .Position = 0
    .Write arrByte
    .SetEOS
    .SaveToFile filePath, 2
    .Close
  End With
  
  Erase arrByte
  With deleteBOMStream
    .Charset = "Unicode"
    .Open
    .LoadFromFile filePath
    ' BOMを削除するための処理
    .Position = 0
    .Type = adTypeBinary
    .Position = 2         'UnicodeのBOMは2バイトになる
    arrByte = .Read
    .Position = 0
    .Write arrByte
    .SetEOS
    .SaveToFile filePath, 2
    .Close
  End With
  
  Set xFSO = Nothing
  Set readStream = Nothing
  Set writeStream = Nothing
  Set deleteCRLFStream = Nothing
  Set deleteBOMStream = Nothing
End Sub

ファイルの移動、ファイル名の変更

' ※ファイルを移動するステートメントは存在しないので、Name で実行する

Dim fromPath As String    ' 移動元ファイルパス
Dim toPath As String      ' 移動先ファイルパス

fromPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
toPath = "C:\まとめ総合\ExcelVBA\111\aaa.xlsx"

Name fromPath As toPath
' fromPathからtoPathへのファイル移動。移動先パスのファイル名と同じ名前のファイルがすでに存在する場合は、エラーが発生

fromPath = "C:\まとめ総合\ExcelVBA\aaa.xlsx"
toPath = "C:\まとめ総合\ExcelVBA\111\DDD.xlsx"
Name fromPath As toPath
' ファイル名を変えて移動も可能

UTF-8、Unicode、Shift-JIS、EUC-JP　のテキストファイルをそれぞれへ変換する

'UTF-8からShift-JISへ変更
Sub ConvertUtf8ToSJIS()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "UTF-8"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText   'UTF-8で読み込んだ内容を、textStrに格納しておく
  .Close
End With

With writeStream
  .Charset = "Shift-JIS"
  .Open
'  .LoadFromFile filePath　　ここでこのコードを入れないように。結果がおかしくなる
  .WriteText textStr       'Shift-JISで書き込み
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub



'UTF-8からUnicodeへ変更
Sub ConvertUtf8ToUnicode()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String
Dim arrByte() As Byte

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "UTF-8"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "Unicode"
  .Open
  .WriteText textStr
  ' BOMを削除するための処理
  .Position = 0
  .Type = adTypeBinary  'バイナリ形式にする
  .Position = 2         'UnicodeのBOMは2バイトなので、2バイト分削る
  arrByte = .Read
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub



'UTF-8からEUC-JPへ変更
Sub ConvertUtf8ToEUC()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "UTF-8"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText   'UTF-8で読み込んだ内容を、textStrに格納しておく
  .Close
End With

With writeStream
  .Charset = "EUC-JP"
  .Open
  .WriteText textStr       'EUC-JPで書き込み
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub



'Shift-JISからUTF-8へ変更
Sub ConvertShiftJisToUTF8()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String
Dim arrByte() As Byte

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "Shift-JIS"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "UTF-8"
  .Open
  .WriteText textStr
  ' BOMを削除するための処理
  .Position = 0
  .Type = adTypeBinary  'バイナリ形式にする
  .Position = 3         'UTF-8のBOMは3バイトなので、3バイト分削る
  arrByte = .Read
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub



'Shift-JISからUnicodeへ変更
Sub ConvertShiftJisToUnicode()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String
Dim arrByte() As Byte

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "Shift-JIS"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "Unicode"
  .Open
  .WriteText textStr
  ' BOMを削除するための処理
  .Position = 0
  .Type = adTypeBinary
  .Position = 2         'UnicodeのBOMは2バイトなので、2バイト分削る
  arrByte = .Read
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub



'Shift-JISからEUC-JPへ変更
Sub ConvertShiftJisToEUC()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "Shift-JIS"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "EUC-JP"
  .Open
  .WriteText textStr       'EUC-JPで書き込み
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub



'UnicodeからUTF-8へ変更
Sub ConvertUnicodeToUTF8()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String
Dim arrByte() As Byte

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "Unicode"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "UTF-8"
  .Open
  .WriteText textStr
  ' BOMを削除するための処理
  .Position = 0
  .Type = adTypeBinary  'バイナリ形式にする
  .Position = 3         'UTF-8のBOMは3バイトなので、3バイト分削る
  arrByte = .Read
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub




'UnicodeからShift-JISへ変更
Sub ConvertUnicodeToShiftJis()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "Unicode"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "Shift-JIS"
  .Open
  .WriteText textStr       'Shift-JISで書き込み
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub



'UnicodeからEUC-JPへ変更
Sub ConvertUnicodeToEUC()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "Unicode"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "EUC-JP"
  .Open
  .WriteText textStr       'EUC-JPで書き込み
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub



'EUC-JPからUTF-8へ変更
Sub ConvertEUCToUTF8()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String
Dim arrByte() As Byte

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "EUC-JP"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "UTF-8"
  .Open
  .WriteText textStr
  ' BOMを削除するための処理
  .Position = 0
  .Type = adTypeBinary  'バイナリ形式にする
  .Position = 3         'UTF-8のBOMは3バイトなので、3バイト分削る
  arrByte = .Read
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub


'EUC-JPからUnicodeへ変更
Sub ConvertEUCToUnicode()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String
Dim arrByte() As Byte

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "EUC-JP"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "Unicode"
  .Open
  .WriteText textStr
  ' BOMを削除するための処理
  .Position = 0
  .Type = adTypeBinary
  .Position = 2         'UnicodeのBOMは2バイトなので、2バイト分削る
  arrByte = .Read
  .Position = 0
  .Write arrByte
  .SetEOS
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub


'EUC-JPからShift-JISへ変更
Sub ConvertEUCToShiftJis()

Dim readStream As Object
Dim writeStream As Object
Dim filePath As String
Dim textStr As String

Set readStream = CreateObject("ADODB.Stream")
Set writeStream = CreateObject("ADODB.Stream")
filePath = "C:\work\aaa.txt"

With readStream
  .Charset = "EUC-JP"
  .Open
  .LoadFromFile filePath
  textStr = .ReadText
  .Close
End With

With writeStream
  .Charset = "Shift-JIS"
  .Open
  .WriteText textStr       'Shift-JISで書き込み
  .SaveToFile filePath, 2
  .Close
End With

Set readStream = Nothing
Set writeStream = Nothing

End Sub

フォルダを作成する

Dim folderPath As String
folderPath = "C:\まとめ総合\ExcelVBA\makeDIR"

MkDir folderPath
' フォルダを作成する。すでに存在するパスを指定するとエラーになる

If Dir(folderPath, vbDirectory) = "" Then
    MkDir folderPath
Else
    MsgBox "そのパスのフォルダがすでに存在します"
End If
' エラー回避のためにこれくらいは必要か


' FSOでの方法
Dim xFSO As New FileSystemObject
Dim result As String
folderPath = "C:\まとめ総合\ExcelVBA\FSO"

result = xFSO.CreateFolder(folderPath)
' FSOでフォルダ作成。作成に成功すると、フォルダのパスを返す
MsgBox result & " のフォルダを作成しました"

Set xFSO = Nothing

フォルダを削除する

RmDir "C:\まとめ総合\ExcelVBA\xxx"
' フォルダを削除する｡ファイルの入っているフォルダを削除するとエラーになるので注意

On Error Resume Next
RmDir "C:\まとめ総合\ExcelVBA\yyy"  ' ファイルの入っているフォルダを削除
If Err.number <> 0 Then
    MsgBox "そのフォルダは存在しないか、ファイルが入っています"
End If
On Error GoTo 0


' FSOを使う方法
Dim xFSO As New FileSystemObject

xFSO.DeleteFolder "C:\まとめ総合\ExcelVBA\qqq"
' フォルダを削除。フォルダ内にファイルがあっても削除できる

On Error Resume Next
xFSO.DeleteFolder "C:\まとめ総合\ExcelVBA\ttt"
' フォルダ内に読み取り専用のファイルがあると、エラーになるので注意
' FSOのフォルダ削除は、フォルダ内のファイルを全削除→フォルダ削除の順になるので、読み取り専用のファイル以外はこの時点で削除される

If Err.number = 70 Then  ' 読み取り専用のファイルを削除できなかった場合のエラーコードは「70」
    MsgBox "そのフォルダ内に読み取り専用ファイルがあるので、削除できません"
End If

On Error GoTo 0


xFSO.DeleteFolder "C:\まとめ総合\ExcelVBA\ppp", True
' 第二引数に"True"を指定すると、読み取り専用ファイルも削除できる

Set xFSO = Nothing

フォルダをコピーする

Dim xFSO As New FileSystemObject
Dim motherPath As String    ' コピー元フォルダパス
Dim childPath As String     ' コピー先フォルダパス

motherPath = "C:\まとめ総合\ExcelVBA\ttt"
childPath = "C:\まとめ総合\ExcelVBA\kkk"

xFSO.CopyFolder motherPath, childPath
' フォルダをコピー。コピー先フォルダのパスがすでに存在していると、エラーになる
       
Set xFSO = Nothing

フォルダをコピーする

Dim xFSO As New FileSystemObject
Dim motherPath As String    ' コピー元フォルダパス
Dim childPath As String     ' コピー先フォルダパス

motherPath = "C:\まとめ総合\ExcelVBA\ttt"
childPath = "C:\まとめ総合\ExcelVBA\kkk"

xFSO.CopyFolder motherPath, childPath
' フォルダをコピー。コピー先フォルダのパスがすでに存在していると、エラーになる
    
    
Set xFSO = Nothing

FSOの基本

Sub aaa()

' FSOオブジェクトの作成。3つのうち、どれでもいいかな

Dim FSO1 As FileSystemObject
' 参照設定で、Microdoft Scripting Runtimeの参照が必要
Set FSO1 = New FileSystemObject
MsgBox FSO1.GetFolder("C:\work").Files.Count

Dim FSO2 As Object
Set FSO2 = CreateObject("Scripting.FileSystemObject")
' この方法は、Microdoft Scripting Runtimeの参照は必要なし
MsgBox FSO2.GetFolder("C:\work").Files.Count

With CreateObject("Scripting.FileSystemObject")
' この方法は、Microdoft Scripting Runtimeの参照は必要なし
  MsgBox .GetFolder("C:\work").Files.Count
End With

Set FSO1 = Nothing  'オブジェクトの解放。しなくても大丈夫と言う説もあるが・・
Set FSO2 = Nothing

End Sub
    
    
    
'    ※FSOのプロパティ
'    Drives システムに接続されたDrivesコレクションを返します
    
    
'    ※FSOのメソッド
'    BuildPath            パスの末尾に､指定したフォルダ名を追加したパスを返します
'    CopyFile             ファイルをコピーします
'    CopyFolder           フォルダをコピーします
'    CreateFolder         新しいフォルダを作成します
'    CreateTextFile       新しいテキストファイルを作成します
'    DeleteFile           ファイルを削除します
'    DeleteFolder         フォルダを削除します
'    DriveExists          ドライブが存在するかどうか調べます
'    FileExists           ファイルが存在するかどうか調べます
'    FolderExists         フォルダが存在するかどうか調べます
'    GetAbsolutePathName  省略したパスから完全なパス名を返します
'    GetBaseName          拡張子を除いたファイルのベース名を返します
'    GetDrive             指定したDriveオブジェクトを返します
'    GetDriveName         指定したドライブの名前を返します
'    GetExtensionName     ファイルの拡張子を返します
'    GetFile              指定したFileオブジェクトを返します
'    GetFileName          指定したファイルの名前を返します
'    GetFolder            指定したFolderオブジェクトを返します
'    GetParentFolderName  指定したフォルダの親フォルダを返します
'    GetSpecialFolder     システムが使用する特別なフォルダのパスを返します
'    GetTempName          一時的なファイル名を生成します
'    MoveFile             ファイルを移動します
'    MoveFolder           フォルダを移動します
'    OpenTextFile         指定したTextStreamオブジェクトを返します


'    ※FSOのDriveオブジェクトのプロパティ
'    AvailableSpace   使用できるディスク容量を返します
'    DriveLetter      ドライブ名を返します
'    DriveType        ドライブの種類を示す値を返します
'    FileSystem       ドライブが使用しているファイルシステムの種類を返します
'    FreeSpace        使用できるディスク容量を返します
'    IsReady          ドライブの準備ができているかどうかを返します
'    path             ドライブのパスを返します
'    RootFolder       ドライブのルートフォルダを返します
'    SerialNumber     ディスクのシリアル値を返します
'    ShareName        ドライブのネットワーク共有名を返します
'    TotalSize        ドライブの総容量を返します
'    VolumeName       ドライブのボリューム名を設定します


'    ※FSOのFolderオブジェクトのプロパティ
'    Attributes         フォルダの属性を設定します
'    DateCreated        フォルダが作成された日付と時刻を返します
'    DateLastAccessed   フォルダが最後にアクセスされたときの日付と時刻を返します
'    DateLastModified   フォルダが最後に更新されたときの日付と時刻を返します
'    Drive              フォルダが存在するドライブの名前を返します
'    Files              フォルダ内の全てのファイルを返します
'    IsRootFolder       フォルダがルートフォルダかどうかを返します
'    Name    　         フォルダの名前を設定します
'    ParentFolder       フォルダの親フォルダを返します
'    path               フォルダのパスを返します
'    ShortName   　     フォルダの8.3形式の名前を返します
'    ShortPath   　     フォルダの8.3形式のパスを返します
'    Size               フォルダ内の全てのファイルサイズ合計を返します
'    SubFolders         フォルダ内の全てのサブフォルダを返します
'    Type               フォルダの種類を返します


'    ※FSOのFolderオブジェクトのメソッド
'    Copy               フォルダをコピーします
'    CreateTextFile     新しいテキストファイルを作成します
'    Delete             フォルダを削除します
'    Move               フォルダを移動します



'    ※FSOのFileオブジェクトのプロパティ
'    Attributes         ファイルの属性を設定します
'    DateCreated        ファイルが作成された日付と時刻を返します
'    DateLastAccessed   ファイルが最後にアクセスされたときの日付と時刻を返します
'    DateLastModified   ファイルが最後に更新されたときの日付と時刻を返します
'    Drive              ファイルが存在するドライブの名前を返します
'    Name               ファイルの名前を返します
'    ParentFolder       ファイルが存在するフォルダを返します
'    path               ファイルのパスを返します
'    ShortName          ファイルの8.3形式の名前を返します
'    ShortPath          ファイルの8.3形式のパスを返します
'    Size               ファイルのサイズを返します
'    Type               ファイルの種類を返します


'    ※FSOのFileオブジェクトのメソッド
'    Copy                ファイルをコピーします
'    Delete              ファイルを削除します
'    Move                ファイルを移動します
'    OpenAsTextStream    テキストファイルを開きます


'    ※FSOのTextStreamオブジェクトのプロパティ
'    AtEndOfLine      ファイルポインタが終端かどうかを返します
'    AtEndOfStream    ファイルポインタが終端かどうかを返します
'    Column           ファイルポインタの文字位置を返します
'    Line             ファイルポインタの行位置を返します


'    ※FSOのTextStreamオブジェクトのメソッド
'    Close             テキストファイルを閉じます
'    Read              指定した文字数だけ読み込みます
'    ReadAll           すべての文字を読み込みます
'    ReadLine          1行分の文字を読み込みます
'    Skip              指定した文字数だけスキップします
'    SkipLine          1行分スキップします
'    Write             指定した文字を書き込みます
'    WriteBlankLines   改行を書き込みます
'    WriteLine         1行分の文字を書き込みます

テキストファイルの行数を取得する

Dim xFSO As New FileSystemObject

With xFSO.OpenTextFile("C:\まとめ総合\ExcelVBA\aaa.txt", 8)
' 追記モードでテキストファイルを開く
    MsgBox "行数は： " & .Line
    ' 現在カーソルのある行の行番号を取得。追記モードで開くとカーソルは最終行にあるので、結果として行数を得られる
    .Close
End With

Set xFSO = Nothing

指定されたパスのフォルダが存在しない場合、新規に作成する

' ※FSOと再帰処理を使う方法。コードが短いのでおすすめ。再帰の部分は不思議な感じの動作をする

Sub aaa()

    Dim newPath As String
    
    newPath = "C:\work\AAA\BBB\CCC\DDD"
    ' "C:\work" までしか存在しない状態
    ' "C:\work\AAA\BBB\CCC\DDD"というパスのフォルダを作ろうとしてもできない。"C:\work\AAA"から作っていく必要がある
    
    If Dir(newPath, vbDirectory) = "" Then
        Call MakeFolder(newPath)   ' フォルダを作成する処理を呼び出し
        MsgBox "フォルダを作成しました"
    Else
        MsgBox "そのフォルダは存在します"
    End If
    
End Sub


Sub MakeFolder(newPath As String)  ' フォルダを作成する

    Dim xFSO As New FileSystemObject
    Dim parentFolder_Name As String     ' 親フォルダの名前
    
    parentFolder_Name = xFSO.GetParentFolderName(newPath)
    ' 親フォルダの名前を取得。Nameとあるが、実際はフォルダのフルパス
    
    If Not xFSO.FolderExists(parentFolder_Name) Then  ' 親フォルダが存在しない場合
        Call MakeFolder(parentFolder_Name)
        ' 親フォルダを対象として、自分自身を呼び出す再帰処理
    End If
    
    xFSO.CreateFolder newPath  ' フォルダを作成
    
    Set xFSO = Nothing

End Sub


' ※ DLLのプロシージャを利用して、一気に指定パスのフォルダを作る方法。安定しないかも

Option Explicit

Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" ( _
    ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Long) As Long
' DLLのプロシージャへの外部参照宣言。何なのかはよくわからん
                                                                  

Sub aaa()
    Dim returnCount As Long
    Dim newPath As String
    
    newPath = "C:\work\111\222\3333\44444"
    ' 新規に作成するフォルダパス。現在は"C:\work"までしか存在しない状態

    returnCount = SHCreateDirectoryEx(0&, newPath, 0&)
    ' これで一気に "C:\work\111\222\3333\44444" のフォルダを作成できる。戻り値がある
    
    If returnCount = 0 Then  ' 戻り値が0の場合、新規に作成成功
        MsgBox newPath & "を作成しました"
        
    ElseIf returnCount = 183 Then   ' 戻り値が183の場合、そのフォルダはすでに存在する
        MsgBox newPath & "は存在しています"
        
    Else
        MsgBox newPath & "を作成できませんでした"
    End If
    
End Sub



' ※以前に自分で考えたコード。パスを「\」区切りで分割し、配列に格納して1階層ずつフォルダを作っていく
' Split関数を使えば、もっと簡単だったな

Sub Check_MakeFolder()  ' 指定された保存先フォルダの存在確認と新規フォルダ作成

    Dim objFolder As Object             ' フォルダ
    Dim pathBunkatsu() As String        ' パスを「￥」区切りで分割し、格納する配列
    Dim strPath As String
    Dim lastPath As String
    Dim i As Long

    strPath = "C:\work\1111\2222\33333\4444\55555555"
    Erase pathBunkatsu
    ReDim Preserve pathBunkatsu(1)
    
    ' パスの文字列を「￥」区切りで後ろ側から分解していく
    On Error GoTo ErrorHandler
    Do While Dir(strPath, vbDirectory) = ""
        pathBunkatsu(UBound(pathBunkatsu)) = Mid(strPath, (InStrRev(strPath, "\")), (Len(strPath) - (InStrRev(strPath, "\")) + 1))
        ReDim Preserve pathBunkatsu(UBound(pathBunkatsu) + 1)
        strPath = Mid(strPath, 1, (InStrRev(strPath, "\") - 1))
        If Dir(strPath, vbDirectory) <> "" Then
            lastPath = strPath
            Exit Do
        End If
    Loop
    On Error GoTo 0
    
    i = UBound(pathBunkatsu) - 1
    Do While i > 0
        lastPath = lastPath & pathBunkatsu(i)
        MkDir (lastPath)   ' フォルダ作成
        i = i - 1
    Loop
            
        
ReturnFromError:
        
    Erase pathBunkatsu
    
    Exit Sub
    
ErrorHandler:
    ' 特に何もせず、ReturnFromErrorまで戻る
    Resume ReturnFromError

End Sub

デスクトップ、マイドキュメントなどの特殊フォルダのパスを取得する

Dim WSH As Variant
Dim folderPath As String

Set WSH = CreateObject("WScript.Shell")   ' よくわからないが、何かのオブジェクト

'    folderPath = WSH.Specialfolders("Desktop")  ' デスクトップのパスを取得
'
'    Workbooks.Add
'    ActiveWorkbook.SaveAs Filename:=folderPath & "\" & "WSH.xlsx"  ' 新規ブックを作成してデスクトップに保存

folderPath = WSH.Specialfolders("MyDocuments")  ' マイドキュメント
Debug.Print folderPath

folderPath = WSH.Specialfolders("NetHood")  ' ネットワーク
Debug.Print folderPath

folderPath = WSH.Specialfolders("PrintHood")  ' プリンタ
Debug.Print folderPath

folderPath = WSH.Specialfolders("Recent")  ' 最近使ったファイル
Debug.Print folderPath

folderPath = WSH.Specialfolders("Favorites")  ' お気に入り
Debug.Print folderPath

' ※他にもあり

ファイル・フォルダへのショートカットを作成する

Dim WSH As Variant
Dim LnkFile As Variant    ' ショートカット
Dim filePath As String

Set WSH = CreateObject("WScript.Shell")

filePath = WSH.specialfolders("Desktop") & "\" & "メモ帳.lnk"
Set LnkFile = WSH.createShortcut(filePath)
LnkFile.TargetPath = "%SystemRoot%\System32\notepad.exe"
' デスクトップにメモ帳へのショートカットを作る

LnkFile.Save


filePath = WSH.specialfolders("Desktop") & "\" & "「サンプルテキスト」フォルダ.lnk"
Set LnkFile = WSH.createShortcut(filePath)
LnkFile.TargetPath = "C:\まとめ総合\ExcelVBA\サンプルテキスト"
' デスクトップにフォルダへのショートカットを作る
LnkFile.Save


filePath = WSH.specialfolders("Desktop") & "\" & "0100テキスト.lnk"
Set LnkFile = WSH.createShortcut(filePath)
LnkFile.TargetPath = "C:\まとめ総合\ExcelVBA\サンプルテキスト\0100.txt"
' デスクトップにテキストファイルへのショートカットを作る
LnkFile.Save

Set LnkFile = Nothing
Set WSH = Nothing

ショートカットのリンク先パスを取得する

Dim WSH As Variant
Dim LnkFile As Variant    ' ショートカット
Dim filePath As String

Set WSH = CreateObject("WScript.Shell")

filePath = WSH.SpecialFolders("Desktop") & "\" & "「サンプルテキスト」フォルダ.lnk"
' このパスは、すでに存在するショートカットのもの

Set LnkFile = WSH.CreateShortcut(filePath)
' WSH.CreateShortcut(filePath)　は、ショートカットを作るためのものだが、ショートカットのオブジェクトを戻り値として返す

MsgBox "ショートカットのリンク先パスは： " & LnkFile.TargetPath
' これでショートカットのリンク先パスが取得できる

Set LnkFile = Nothing
Set WSH = Nothing

ファイルを即削除するのではなく、ごみ箱へ移動する

' ※このコードは、ネット上の丸パクリ。動作は確認済み

' ごみ箱に送るためのAPI
Private Declare Function SHFileOperation Lib "shell32.dll" _
                            (lpFileOp As SHFILEOPSTRUCT) As Long

' SHFileOperation関数に渡すユーザー定義型
Private Type SHFILEOPSTRUCT
    hwnd As Long                      ''ウィンドウハンドル
    wFunc As Long                     ''実行する操作
    pFrom As String                   ''対象ファイル名
    pTo As String                     ''目的ファイル名
    fFlags As Integer                 ''フラグ
    fAnyOperationsAborted As Long     ''結果
    hNameMappings As Long             ''ファイル名マッピングオブジェクト
    lpszProgressTitle As String       ''ダイアログのタイトル
End Type

Private Const FO_DELETE = &H3         ''削除する
Private Const FOF_ALLOWUNDO = &H40    ''ごみ箱に送る

Sub DeleteFile()
    Dim SH As SHFILEOPSTRUCT, re As Long, Target As String
    Target = Application.GetOpenFilename(Title:="削除するファイルを選択してください")
    If Target = "False" Then Exit Sub
    With SH
        .hwnd = Application.hwnd
        .wFunc = FO_DELETE
        .pFrom = Target
        .fFlags = FOF_ALLOWUNDO
    End With
    re = SHFileOperation(SH)
    If re <> 0 Then MsgBox "削除に失敗しました", vbExclamation
End Sub

シートをCSVファイルとして保存する（シートをコピーする方法）

Dim NewFileName As String

Application.DisplayAlerts = False

NewFileName = "Excelをテキスト変換.txt"  ' 新しく作るファイル名

Application.CutCopyMode = False
' シートを移動ではなく、コピーする
ActiveSheet.Copy
ActiveWorkbook.SaveAs Filename:="C:\Users\Benten\Desktop\" & NewFileName, _
    FileFormat:=xlText
    ' タブ区切りのテキストファイルとして保存する

ActiveWorkbook.Save
ActiveWorkbook.Close

Application.DisplayAlerts = True

' 警告メッセージはOFFにしてあるので、同名のファイルがすでに存在する場合は
' 強制的に上書き保存する

UTF-8、4バイト文字(サロゲートペアなど)を含むテキストファイルを読み込み、セルに出力する場合の注意

※4バイト文字を含む文字列内で改行を挿入する場合、vbCrLfを指定すると表示がおかしくなる。必ずvbLfにするように

' ※ ADOを使うので、Microsoft ActiveX Data Objects #.# Library への参照が必要

Dim xStream As New ADODB.stream   ' ADOのストリーム
Dim filePath As String
Dim dataStr As String

filePath = "C:\download\UTF8.txt"   ' UTF-8のテキストファイル。4バイト文字を含み、複数行で構成

With xStream
    .Charset = "UTF-8"   ' 文字コードにUTF-8を指定
    .Open
    .LoadFromFile filePath

    Do Until .EOS    ' ストリームの最後まで
        dataStr = dataStr & .ReadText(-2) & vbLf
        ' 複数行の内容を1つのセルに出力するため、改行コードでつないでいく
        ' この場合、改行コードはvbLfでないとだめ。vbCrLfだと表示が異常になる。あとやたらと動作が重くなってしまう
        
    Loop
    
    Cells(1, 1).Value = dataStr
    
    .Close  ' ストリームを閉じる
    
End With

Set xStream = Nothing

フォルダを選択するダイアログを開く

Sub SelectFolder()   ' フォルダを選択する
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then   ' フォルダが選択された場合
            Cells(41, 2).Value = .SelectedItems(1) & "\"
        Else
            MsgBox "キャンセルされました"
        End If
    
    End With
End Sub

ファイルを選択するダイアログを開く

Sub SelectTextFile()   ' 出力するテキストファイルを選択する

    Dim filename As Variant
    
    filename = Application.GetOpenFilename("テキストファイル(*.txt),*.txt")    ' 拡張子が".txt"のファイルを指定
    
    If VarType(filename) = vbBoolean Then
        MsgBox "キャンセルされました"
    Else
        Cells(41, 2).Value = filename
    End If

End Sub


Sub SelectCSVFile()   ' 出力するCSVファイルを選択する

    Dim filename As Variant
    
    filename = Application.GetOpenFilename("CSVファイル(*.csv),*.csv")    ' 拡張子が".csv"のファイルを指定
    
    If VarType(filename) = vbBoolean Then
        MsgBox "キャンセルされました"
    Else
        Cells(41, 2).Value = filename
    End If

End Sub


Sub SelectExcelFile()
'エクセルファイルを選択するダイアログを開く

  Dim filename As Variant
  
  filename = Application.GetOpenFilename("Excel ファイル (*.xls; *.xlsx; *.xlsm; *.xlsb),*.xls; *.xlsx; *.xlsm; *.xlsb")    ' エクセルファイルを指定
  
  If VarType(filename) = vbBoolean Then
    MsgBox "キャンセルされました"
  Else
    Cells(3, 2).Value = filename
  End If

End Sub



Sub Sample2()   ' 複数ファイル選択
    Dim myFile As Variant
    Dim f As Variant
    
    ChDir "C:\Data"
    myFile = Application.GetOpenFilename( _
         FileFilter:="Excel ファイル (*.xls; *.xlsx),*.xls; *.xlsx", _
         MultiSelect:=True)
    
    If IsArray(myFile) Then
        For Each f In myFile
            Debug.Print f
        Next
    Else
        Debug.Print myFile
    End If
End Sub

指定フォルダ以下にある、フォルダ数とファイル数をカウントする。サブフォルダ内も含める

FSO.GetFolder(topFolderPath).Files.Count　でファイル数が取得できるようだ

Option Explicit

Dim fileCount As Long
Dim folderCount As Long
Dim xFSO As Object
Dim topFolderPath As String

Sub aaa()

  topFolderPath = "C:\work\aaa"
  Set xFSO = CreateObject("Scripting.FileSystemObject")
  fileCount = 0
  folderCount = 0
  
  fileCount = xFSO.GetFolder(topFolderPath).Files.Count
  'フォルダ内のファイル数を取得。直下のファイル数だけはここで取得する
  'xFSO.GetFolder(xPath).Folders.Count というのはできないらしい
  
  Call FolderAndFileSearch(topFolderPath)
  
  Debug.Print "フォルダ数は：" & folderCount
  Debug.Print "ファイル数は：" & fileCount
  
End Sub

Sub FolderAndFileSearch(folderPath As String)

  Dim xFolder As Folder

  For Each xFolder In xFSO.GetFolder(folderPath).SubFolders  ' サブフォルダを取得する
    folderCount = folderCount + 1  'フォルダ数をカウントアップ
    fileCount = fileCount + xFSO.GetFolder(xFolder.Path).Files.Count
    'フォルダ内のファイル数を取得
    
    Call FolderAndFileSearch(xFolder.Path)  ' 再帰処理でサブフォルダまで検索
  Next xFolder

End Sub

Excel2016時点での、Excelファイルの拡張子であると判断するためのコード

Function excelFile(filename As String) As Boolean
' Excelファイルであるかを判定する
  
  Dim right5Str As String

  excelFile = False
  right5Str = Right$(filename, 5)
  
  If Right$(filename, 4) = ".xls" Then
    excelFile = True
  End If
  If (right5Str = ".xlsx") Or (right5Str = ".xlsm") Or (right5Str = ".xltx") Or (right5Str = ".xltm") Or (right5Str = ".xlsb") Then
    excelFile = True
  End If

End Function


実際に開くことのできるファイルはこれくらいなので、後は除外でいいだろう

ファイル選択、フォルダ選択、確認のテンプレート

Sub sss()
  
  Dim folderPath As String
  Dim filePath As String
  
  'ファイルの確認
  If Cells(3, 2) = "" Then
    MsgBox "ファイルが指定されていません"
    Exit Sub
  Else
    filePath = Cells(3, 2)
  End If

  If Dir(filePath) = "" Then
    MsgBox "指定されたファイルは存在しません"
    Exit Sub
  End If
  
  'フォルダの確認
  If Cells(6, 2) = "" Then
    MsgBox "フォルダが指定されていません"
    Exit Sub
  Else
    folderPath = Cells(6, 2)
  End If
  
  If Dir(folderPath, vbDirectory) = "" Then
    MsgBox "指定されたフォルダは存在しません"
    Exit Sub
  End If
  
  If Right$(folderPath, 1) <> "\" Then
  'パスの最後に"\"が無い場合は付与する
    folderPath = folderPath & "\"
  End If 
End Sub


Sub SelectExcelFile()
'エクセルファイルを選択するダイアログを開く

  Dim filename As Variant
  
  filename = Application.GetOpenFilename("Excel ファイル (*.xls; *.xlsx; *.xlsm; *.xlsb),*.xls; *.xlsx; *.xlsm; *.xlsb")    ' エクセルファイルを指定
  
  If VarType(filename) = vbBoolean Then
    MsgBox "キャンセルされました"
  Else
    Cells(3, 2).Value = filename
  End If

End Sub


Sub SelectFolder()   ' フォルダを選択する

  With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
      Cells(6, 2).Value = .SelectedItems(1) & "\"
    Else
      MsgBox "キャンセルされました"
    End If
  
  End With

End Sub

You get articles that match your needs
You can efficiently read back useful information
You can use dark theme

What you can do with signing up

ExcelVBA ファイル関連

フォルダが存在するか確認する

ファイルが存在するか確認する

ファイルのフルパスから、フォルダパスとファイル名を取得する

相対パスでの指定

テキストファイルを読み込む Shift-JISのファイルのみ

テキストファイルに書き込む Shift-JISのみ

UTF-8のテキストファイルを読み込む ADODB.Streamを使用

UTF-8でテキストファイルに書き込む ADODB.Streamを使用

UTF-8、BOM無しでテキストファイルに書き込む

CSVファイルを読み込んで、指定のセルからデータをセットする

UTF-8、BOMありのテキストファイルを、BOMの削除だけをする

UTF-8のCSVファイルを読み込んで、指定のセルからデータをセットする

ADODB.Streamでファイルの文字コードを指定する (UTF-8 Shift-JIS Unicode EUC)

選択しているセル範囲のデータを、UTF-8、BOM無しでCSVファイルとして書き込む

UTF-8のテキストファイルを、Shift-JISに変換する

カレントフォルダの取得・設定、カレントドライブの設定

フォルダ内のファイルを検索する(サブフォルダは含まない)

サブフォルダも含めて、フォルダ内のファイルを検索する

テキストファイルの文字コードを判定する関数の例

文字コードがUnicodeのテキストファイルのBOMを削除する

ファイルの属性を取得・設定する(フォルダも含める)

UTF-8のテキストファイルの内容を変更し、さらにBOMの削除も実行する

ファイルのコピー

Unicodeのテキストファイルを、内容を書き換えてBOMも削除する

ファイルの移動、ファイル名の変更

UTF-8、Unicode、Shift-JIS、EUC-JP のテキストファイルをそれぞれへ変換する

フォルダを作成する

フォルダを削除する

フォルダをコピーする

フォルダをコピーする

FSOの基本

テキストファイルの行数を取得する

指定されたパスのフォルダが存在しない場合、新規に作成する

デスクトップ、マイドキュメントなどの特殊フォルダのパスを取得する

ファイル・フォルダへのショートカットを作成する

ショートカットのリンク先パスを取得する

ファイルを即削除するのではなく、ごみ箱へ移動する

シートをCSVファイルとして保存する（シートをコピーする方法）

UTF-8、4バイト文字(サロゲートペアなど)を含むテキストファイルを読み込み、セルに出力する場合の注意

フォルダを選択するダイアログを開く

ファイルを選択するダイアログを開く

指定フォルダ以下にある、フォルダ数とファイル数をカウントする。サブフォルダ内も含める

Excel2016時点での、Excelファイルの拡張子であると判断するためのコード

ファイル選択、フォルダ選択、確認のテンプレート

ExcelVBA 　ファイル関連

テキストファイルを読み込む　　Shift-JISのファイルのみ

テキストファイルに書き込む　　Shift-JISのみ

UTF-8のテキストファイルを読み込む　　ADODB.Streamを使用

UTF-8でテキストファイルに書き込む　　ADODB.Streamを使用

UTF-8、Unicode、Shift-JIS、EUC-JP　のテキストファイルをそれぞれへ変換する