SDG Keyword Count Program Source Code (Excel VBA)
SDG Keyword Count Program Source Code (Excel VBA)
Sub FillSheet()
Dim strPath As String
Dim strFile As String
Dim r As Long
Dim m As Long
Dim c As Long
Dim tc As Long
Dim objWord As Object
Dim objDoc As Object
Dim blnStart As Boolean
Dim counter As Long
Dim docCount As Long
Dim tCounter As Long
Dim s1Sheet As Worksheet
With Application.FileDialog(4) ' msoFileDialogFolderPicker
If .Show Then
strPath = .SelectedItems(1)
Else
MsgBox "No folder selected.", vbInformation
Exit Sub
End If
End With
On Error Resume Next
Set objWord = GetObject(, "Word.Application")
If objWord Is Nothing Then
Set objWord = CreateObject("Word.Application")
If objWord Is Nothing Then
MsgBox "Can't start Word", vbCritical
Exit Sub
End If
blnStart = True
End If
On Error GoTo ErrHandler
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
Application.ScreenUpdating = False
c = 1
m = Cells(Rows.count, 1).End(xlUp).Row
tc = Cells(2, Columns.count).End(xlToLeft).Column
counter = 0
docCount = 0
If tc <> 1 Then
With Sheets("Sheet1")
Range(.Cells(2, 2), .Cells(m, tc)).ClearFormats
Range(.Cells(2, 2), .Cells(m, tc)).ClearContents
End With
End If
strFile = Dir(strPath & "*.doc*")
Do While strFile <> ""
Set objDoc = objWord.Documents.Open(Filename:=strPath & strFile)
c = c + 1
docCount = docCount + 1
Cells(2, c).Font.Color = vbBlack
Cells(2, c).Font.Bold = False
Cells(2, c) = objDoc.Name
For r = 3 To m
Cells(2, c).Font.Color = vbBlue
Cells(2, c).Interior.ColorIndex = 15
Cells(2, c).HorizontalAlignment = xlCenter
Cells(2, c).VerticalAlignment = xlCenter
counter = 0
With objDoc.Content.Find
.Text = Cells(r, 1)
.Format = False
.Wrap = wdFindStop
Do While .Execute
counter = counter + 1
Loop
End With
' If objDoc.Content.Find.Execute( _
' FindText:=Cells(r, 1), MatchCase:=False, _
' MatchWholeWord:=True) Then
' counter = counter + 1
'End If
Cells(r, c) = counter
Cells(r, c).Font.Bold = False
Next r
objDoc.Close SaveChanges:=False
strFile = Dir
Loop
' MsgBox docCount + 2, vbInformation
' strFile = Dir(strPath & "*.doc*")
' If strFile <> "" Then
Cells(2, docCount + 2) = "Total Count"
Cells(2, docCount + 2).Font.Bold = True
Cells(2, docCount + 2).Interior.ColorIndex = 15
Cells(2, docCount + 2).HorizontalAlignment = xlCenter
Cells(2, docCount + 2).VerticalAlignment = xlCenter
For r = 3 To m
c = 2
tCounter = 0
Cells(r, docCount + 2) = ""
Do While Cells(r, c) <> ""
tCounter = tCounter + Cells(r, c)
c = c + 1
Loop
Cells(r, c) = tCounter
Cells(r, c).Font.Bold = True
Next r
' End If
' strFile = Dir
ExitHandler:
On Error Resume Next
Set objDoc = Nothing
If blnStart And Not objWord Is Nothing Then
objWord.Quit SaveChanges:=False
End If
Set objWord = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub