Sub ExportStyles()
Application.ScreenUpdating = True
Dim i As Long, j As Long, StrWkBkNm As String, StrWkSht As String
Dim xlApp As Object, xlWkBk As Object, xlWkSht As Object
Dim StrStyles As String, bStrt As Boolean, bFound As Boolean
StrStyles = StrStyles & ",Style1,Style2,Style3,Style4,Style5,"
StrStyles = StrStyles & "Style6,Style7,Style8,Style9,Style10,"
StrStyles = StrStyles & "Style11,Style12,Style13,Style14,Style15"
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\Styles.xls"
StrWkSht = "Sheet1": bStrt = False: bFound = False
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
' Test whether Excel is already running.
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
  Set xlApp = CreateObject("Excel.Application")
  If xlApp Is Nothing Then
    MsgBox "Can't start Excel.", vbExclamation
    GoTo ErrExit
  End If
  bStrt = True
End If
On Error GoTo 0
'Check if the workbook is open.
With xlApp
  For Each xlWkBk In .Workbooks
    If xlWkBk.FullName = StrWkBkNm Then ' It's open
      Set xlWkBk = xlWkBk
      bFound = True
      Exit For
    End If
  Next
  ' If not open by the current user.
  If bFound = False Then
    ' Check if another user has it open.
    If IsFileLocked(StrWkBkNm) = True Then
      ' Report and exit if true
      MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
      If bStrt = True Then .Quit
      GoTo ErrExit
    End If
    ' The file is available, so open it.
    Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm)
    If xlWkBk Is Nothing Then
      MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
      If bStrt = True Then .Quit
      GoTo ErrExit
    End If
  End If
End With
Set xlWkSht = xlWkBk.Worksheets(StrWkSht)
' Output the Styles.
For j = 1 To UBound(Split(StrStyles, ","))
  i = 0
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Format = True
      .Text = ""
      .Replacement.Text = ""
      .Wrap = wdFindStop
      .Style = Split(StrStyles, ",")(j)
      .Execute
    End With
    Do While .Find.Found
      i = i + 1
      xlWkSht.Cells(i, j).Value = .Text
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
xlWkBk.Save
xlApp.Visible = True
ErrExit:
' Release Excel object memory
Set xlWkSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub
 
Function IsFileLocked(strFileName As String) As Boolean
  On Error Resume Next
  Open strFileName For Binary Access Read Write Lock Read Write As #1
  Close #1
  IsFileLocked = Err.Number
  Err.Clear
End Function