Excel VBA フォルダ内の全ファイルをループ処理

Sub 親フォルダサンプルマクロ()

    '◆01 データをフォームへコピー
    '自動計算ＯＮ
    Application.Calculation = xlCalculationAutomatic

    '親フォルダの設定
    Dim folderpathsys
    folderpathsys = ThisWorkbook.Path
    
    Dim folderpath
    folderpath = Left(folderpathsys, InStrRev(folderpathsys,"\"))
    
    'フォルダ内のファイルを順番に開く（前半）
    Dim fso As Object
    Dim file As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each file In fso.getFolder(folderpath & "02_メインA_Excel保存").Files
    
    Dim Workbook As Workbook
    Set Workbook = Workbooks.Open(Filename:=file, ReadOnly:=True)
    
    '元ファイル名を取得
    Dim MotoName As String
    MotoName = Workbook.Name


    '◆メイン開始◆
    
    'A1セルに、文字を記入
    Range("A1") = "あいうえお"

    '◆メイン終わり◆


    'Excel形式に変更して、別フォルダへ保存
    Dim SaveName As String
    Dim lFindPoint As Long
    Dim lStrLen As Long
    
    '文字列の右端から"."を検索し、左端からの位置を取得する
    lFindPoint = InStrRev(MotoName, ".")

    '拡張子を除いたファイル名の取得&日付入れる
    SaveName = Left(MotoName, lFindPoint - 1) & "_" & Format(Date, "yyyymmdd")

    '保存先を設定
    Dim SavePath As String
    SavePath = folderpath & "02_メインB_Excel加工"
       
    'フルパスを指定して保存
    ActiveWorkbook.SaveAs Filename:=SavePath & "\" & SaveName _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    
    ActiveWorkbook.Close
    
    
    
    'フォルダ内のファイルを順番に開く（後半）
    Next
    
    
End Sub

Sub 親フォルダサンプルマクロ()

'◆01 データをフォームへコピー

'自動計算ＯＮ

Application.Calculation = xlCalculationAutomatic

'親フォルダの設定

Dim folderpathsys

folderpathsys = ThisWorkbook.Path

Dim folderpath

folderpath = Left(folderpathsys, InStrRev(folderpathsys,"\"))

'フォルダ内のファイルを順番に開く（前半）

Dim fso As Object

Dim file As Object

Set fso = CreateObject("Scripting.FileSystemObject")

For Each file In fso.getFolder(folderpath & "02_メインA_Excel保存").Files

Dim Workbook As Workbook

Set Workbook = Workbooks.Open(Filename:=file, ReadOnly:=True)

'元ファイル名を取得

Dim MotoName As String

MotoName = Workbook.Name

'◆メイン開始◆

'A1セルに、文字を記入

Range("A1") = "あいうえお"

'◆メイン終わり◆

'Excel形式に変更して、別フォルダへ保存

Dim SaveName As String

Dim lFindPoint As Long

Dim lStrLen As Long

'文字列の右端から"."を検索し、左端からの位置を取得する

lFindPoint = InStrRev(MotoName, ".")

'拡張子を除いたファイル名の取得&日付入れる

SaveName = Left(MotoName, lFindPoint - 1) & "_" & Format(Date, "yyyymmdd")

'保存先を設定

Dim SavePath As String

SavePath = folderpath & "02_メインB_Excel加工"

'フルパスを指定して保存

ActiveWorkbook.SaveAs Filename:=SavePath & "\" & SaveName _

, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

ActiveWorkbook.Close

'フォルダ内のファイルを順番に開く（後半）

End Sub

Comments