複数のワークブックのフォントの変更（Microsoft Excel）

Sub ChangeFontNames()

Dim vNamesFind     Dim vNamesReplace     Dim sFileName As String     Dim Wkb As Workbook     Dim Wks As Worksheet     Dim rCell As Range     Dim x As Integer     Dim iFonts As Integer     Dim sPath As String

'Change these lines as appropriate     'These are the fontnames to find     vNamesFind = Array("Arial", "Allegro BT")

'These are the fontnames to replace     vNamesReplace = Array("Wingdings", "Times New Roman")

'This is the folder to look for xls files     sPath = "C:\foldername\"



Application.ScreenUpdating = False     iFonts = UBound(vNamesFind)

If iFonts <> UBound(vNamesReplace) Then         MsgBox "Find and Replace Arrays must be the same size"

Exit Sub     End If     sFileName = Dir(sPath & "*.xls")

Do While sFileName <> ""

Set Wkb = Workbooks.Open(sPath & sFileName)

For Each Wks In Wkb.Worksheets             For Each rCell In Wks.UsedRange                 For x = 0 To iFonts                     With rCell.Font                         If .Name = vNamesFind(x) Then _                             .Name = vNamesReplace(x)

End With                 Next             Next         Next         Wkb.Close(True)

sFileName = Dir     Loop     Application.ScreenUpdating = True     Set rCell = Nothing     Set Wks = Nothing     Set Wkb = Nothing End Sub