複数あるExcelファイルを開いて列幅調整

先日、このような困りごとをお見掛けした。

1. システムから吐き出された複数のExcelファイルがある。
2. 機械的に吐き出されているため、列幅未調整で、文字が見切れている。
3. これらのファイル全てについて、列幅を自動調整する必要がある。

挑戦してみた。

まず、いつもの「なんちゃって個人情報」から、対象となるファイルっぽい
ものを作成してみた。

中身は、こんな感じだ。

今回は、こんな作戦で行ってみよう。
まず、サブプロシージャは二つ作成する。

1. ファイル内の列幅調整用。
2. 複数ファイルに対する処理ループ用。

列幅調整については、セル内で折り返されている場合を考慮して、
一旦びよーんと伸ばしてから自動調整してみよう。

まず、繰り返し処理用サブプロシージャがこちら。

Sub 繰り返し処理()
    
    Application.ScreenUpdating = False

    ' ファイルが保存されているところ。
    Dim FolderPath As String
        FolderPath = "C:\Temp"
        
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim File As Object
    Dim Wb As Workbook
    Dim NewName As String
    
    ' FolderPath内のファイルを一つずつ取り出して処理。
        For Each File In FSO.GetFolder(FolderPath).Files
            Set Wb = Workbooks.Open(File.Path)
            ' 編集後のファイル名。
                NewName = FSO.GetParentFolderName(File) & "\" & _
                          FSO.GetBaseName(File) & _
                          "_列幅調整済み.xlsx"
            ' 列幅調整用サブプロシージャ呼び出し。
            Call 列幅調整(Wb, NewName)
        Next
    
    Application.ScreenUpdating = False
    
End Sub

次に、開かれたファイルの列幅を調整する。ただし、以下を前提とする。

1. 各ファイル内の対象シートは一つのみ。
2. 調整後のファイルは、別名保存する。

こんな感じだ。

Sub 列幅調整(Wb As Workbook, new_name As String)
    If Wb Is Nothing Then Exit Sub
    
    With Wb.Sheets(1).Cells
    
        ' セル内で折り返されている場合を想定して、
        ' 一旦思い切り列幅を伸ばす。
        .ColumnWidth = 100
    
        ' 列幅と行高さを自動調整。
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
        
    End With
    
    ' 別名保存。
    Wb.Close SaveChanges:=True, _
             Filename:=new_name
End Sub

実行してみると、各ファイルの編集後ファイルが作成されている。

中身の調整も、上手く行ったようだ。

なお、上記を実際に使用する場合は、編集後と同じ名前のファイル名が
既に存在する場合の処理も必要かもしれません。

参考まで。