Option Explicit
Sub test()
Dim ws As Worksheet
Dim p As String, f As String
Dim c As Range, i As Long, n As Long, k As Long
p = "C:\*******\****\"
Application.ScreenUpdating = False
Set ws = ActiveSheet
ws.UsedRange.ClearContents
f = Dir(p & "*.xlsx")
Do While f <> ""
With Workbooks.Open(p & f).Sheets(1)
For Each c In .Cells(1).CurrentRegion.Columns
n = 0
For i = 2 To c.Cells.Count
If c.Cells(i).Interior.ColorIndex <> xlNone Then n = n + 1
Next
c.Cells(i + 1).Value = n
Next
k = k + 1
ws.Cells(k, 1).Value = f
ws.Cells(k, 2).Resize(, 14).Value = .Cells(i + 1, 1).Resize(, 14).Value
.Parent.Close True
End With
f = Dir()
Loop
End Sub
マナ