Excel黒字化

``
Dim cnt As Long

Public Sub ChangeCharacterColor(path, flag)

Dim wb As Workbook
Dim ws As Worksheet
Dim i_WksCnt As Integer
Dim intIdx As Integer
Dim sName As String

Set wb = Workbooks.Open(path)

i_WksCnt = wb.Worksheets.Count

For intIdx = 1 To i_WksCnt
    sName = wb.Worksheets(intIdx).Name

    Set ws = wb.Worksheets(intIdx)
    ws.Activate
    ws.Cells.Select
    
    With Selection.Font
    .ColorIndex = 1
    .TintAndShade = 0
    End With
    
    '各シートA1を選択
    ws.Cells(1, 1).Select
    
    If flag = True Then
    
        For i = 1 To ws.Shapes.Count
        With ws.Shapes(i).TextFrame.Characters
            .Font.Color = RGB(0, 0, 0)
        End With
        Next i
    
    End If
    
    
    
    
    
Next

'先頭シートに戻す
Set ws = wb.Worksheets(1)
ws.Activate

wb.Save
wb.Close

Set wb = Nothing

End Sub

'Main procedure
Public Sub Create_BookList_From_Folder(dir)
Dim MyPath As String
Dim stKekka As Worksheet
Set stKekka = ThisWorkbook.Worksheets("FILE_LIST")
MyPath = dir
cnt = 1
With stKekka
.Cells.ClearContents
.Cells(1, 2).Value = "対象"
.Cells(1, 3).Value = "ファイルパス"
.Cells(1, 4).Value = "フォルダ名"
.Cells(1, 5).Value = "ファイル名"
End With
Call Create_BookList_From_Folder2(MyPath)
End Sub

Private Sub Create_BookList_From_Folder2(MyPath As String)
Dim buf As String
Dim stKekka As Worksheet
Set stKekka = ThisWorkbook.Worksheets("FILE_LIST")

'ファイルの処理
buf = dir(MyPath & "\" & "*.*")
Do While buf <> ""
    If (MyPath & "\" & buf) Like "*.xlsx" Then
        cnt = cnt + 1
        With stKekka
            .Cells(cnt, 3).Value = MyPath & "\" & buf
            .Cells(cnt, 4).Value = MyPath
            .Cells(cnt, 5).Value = buf
        End With
    End If
    buf = dir()
Loop

'サブフォルダの数だけ自分自身を呼び出す。
With CreateObject("Scripting.FileSystemObject")
    For Each f In .GetFolder(MyPath).SubFolders
        Call Create_BookList_From_Folder2(f.path)
    Next f
End With

End Sub

``

``
Sub CreateFileList_Click()

Dim dir As String

dir = ThisWorkbook.Worksheets("Main").Range("BASE_DIR")

'リスト作成
Create_BookList_From_Folder dir

MsgBox "ファイルリストを作成しました。", vbInformation

End Sub
Sub Kurojika()

Dim ws As Worksheet
Dim cnt As Long
Dim fName As String
Dim chkVal As String
Dim bFlag As Boolean

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


Set ws = ThisWorkbook.Worksheets("FILE_LIST")

chkVal = ThisWorkbook.Worksheets("Main").Range("TRAGET_OBJ")

bFlag = False
If chkVal = "オブジェクト対象" Then
    bFlag = True
End If

cnt = 2

Do
   fName = ws.Cells(cnt, "C")
    
    If fName = "" Then
        Exit Do
    End If
    
    ChangeCharacterColor fName, bFlag
    
    cnt = cnt + 1
Loop

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "対象ファイルの黒字化が終了しました。", vbInformation

End Sub
``