Microsoft Office Forums - View Single Post - [Solved] Sharing macro across multiple users/documents

macropod · 03-20-2025, 03:30 PM

At most, you need a single document in a workgroup folder for each department. I wouldn't recommend using Word's Normal template for this.

If you add the following ExtractStats macro & associated code to a docm document containing a list of your key terms with single paragraph breaks between them, then run the macro, it will generate an Excel report giving a frequency count for each key term in each document in the selected folder. And, if the selected folder has subfolders, those will be included in the processing. The document can be stored in any folder, but storing it in a workgroup folder makes it accessible to all users. The output workbook will in any case be output to the user's own Documents folder.

You should be able to see the progress on the Word Status bar as Word opens and processes each document in the background.

Code:

Option Explicit
Dim FSO As Object, oFolder As Object, StrFldrs As String, strDocNm As String, FndArray() As String, StrOut As String
 
Sub ExtractStats()
Application.ScreenUpdating = False: Application.DisplayAlerts = wdAlertsNone: Application.WordBasic.DisableAutoMacros True
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
Dim xlApp As Object, xlWkBk As Object, StrTmp As String, r As Long, c As Long, StrXlNm As String
TopLevelFolder = GetFolder: StrFldrs = vbCr & TopLevelFolder: If TopLevelFolder = "" Then Exit Sub
strDocNm = ThisDocument.FullName: FndArray = Split(ThisDocument.Range.Text, vbCr)
StrOut = vbCr & vbTab & "Folder" & vbTab & "Filename" & vbTab & Join(FndArray, vbTab)
If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFldrs, vbCr))
  Call ProcessDocuments(CStr(Split(StrFldrs, vbCr)(i)))
Next
Application.WordBasic.DisableAutoMacros False: Application.DisplayAlerts = wdAlertsAll: Application.ScreenUpdating = True
StrXlNm = "\Documents\KeyWordStats (" & Format(Now, "YYYYMMDDhhmm") & ").xlsx"
Application.StatusBar = "Generating Output Workbook: " & StrXlNm
'Output the results to a new Excel workbook
Set xlApp = CreateObject("Excel.Application")
With xlApp
  .Visible = False
  Set xlWkBk = .Workbooks.Add
  ' Update the workbook.
  With xlWkBk.Worksheets(1)
    For r = 1 To UBound(Split(StrOut, vbCr))
      StrTmp = Split(StrOut, vbCr)(r)
        For c = 1 To UBound(Split(StrTmp, vbTab))
          .Cells(r, c).Value = Split(StrTmp, vbTab)(c)
        Next
    Next
    .Columns.AutoFit: .Rows.AutoFit
  End With
  xlWkBk.SaveAs FileName:="C:\Users\" & Environ("Username") & StrXlNm
  xlWkBk.Close: .Quit: Set xlWkBk = Nothing: Set xlApp = Nothing
End With
MsgBox "Finished. Results in: " & StrXlNm
End Sub
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders: StrFldrs = StrFldrs & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub

Sub ProcessDocuments(StrFldrNm As String)
Dim StrFlNm As String, wdDoc As Document, x As Long, y As Long
StrFlNm = Dir(StrFldrNm & "\*.doc", vbNormal)
While StrFlNm <> ""
  If StrFldrNm & "\" & StrFlNm <> strDocNm Then
    StrOut = StrOut & vbCr & vbTab & StrFldrNm & vbTab & StrFlNm
    Set wdDoc = Documents.Open(FileName:=StrFldrNm & "\" & StrFlNm, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      On Error Resume Next
      If .ProtectionType = wdAllowOnlyFormFields Then .Unprotect
      On Error GoTo 0
      If .ProtectionType = wdAllowOnlyFormFields Then StrOut = StrOut & vbTab & "Unable to Process - Protected": GoTo Prot
      'Get the stats for each keyword
      For x = 0 To UBound(FndArray) - 1
        With .Range
          With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = FndArray(x)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
          End With
          On Error Resume Next
          Do While .Find.Execute
            y = y + 1
            .Collapse wdCollapseEnd
          Loop
        End With
        StrOut = StrOut & vbTab & y: y = 0
      Next
Prot:
      .Close SaveChanges:=False
    End With
  End If
  DoEvents: StrFlNm = Dir()
Wend
Set wdDoc = Nothing
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

If generating the report is made the responsibility of one person in each department, only that person should need access to the document containing the macro.