Alterations to Word Count macro|VBA & Macros|Excel Forum|My Online Training Hub

Option Explicit
Sub CountPagesInDocs()
Const wdStatisticPages = 2
Dim wsStats As Worksheet
Dim objWrd As Object
Dim objDoc As Object
Dim strFileName As String
Dim strPath As String
Dim arrStats()
Dim cnt As Long

strPath = "C:\Test\" ' change this to the folder/path where you are storing your Word documents

strFileName = Dir(strPath & "*.doc*")

Set objWrd = CreateObject("Word.Application")

objWrd.Visible = False

Do While Len(strFileName) <> 0
ReDim Preserve arrStats(1 To 2, cnt)
Set objDoc = objWrd.Documents.Open(strPath & strFileName)

arrStats(1, cnt) = strFileName

arrStats(2, cnt) = objDoc.ComputeStatistics(wdStatisticPages)

objDoc.Close
cnt = cnt + 1
strFileName = Dir
Loop

objWrd.Quit

Set objWrd = Nothing

Set wsStats = Sheets.Add

With wsStats
.Range("A1:B1").Value = Array("Document Name", "No of Pages")
.Range("A2:B2").Resize(UBound(arrStats, 2) + 1).Value = Application.Transpose(arrStats)
.Range("A1:B1").EntireColumn.AutoFit
End With

End Sub