Private Sub Tools_Custom_Document_Properties_Alpha_Sort_Recreate()
'
' get all custom document properties
' sort alphabetically, delete, then recreate
' custom properties display in the order they were added
'
    Dim docCustomProperty As DocumentProperty
    Dim intDeleted As Integer, intCreated As Integer
    Dim arrCustomDocProps() As String
    Dim varCounter As Variant
    
    ReDim Preserve arrCustomDocProps(0)
    arrCustomDocProps(0) = ""
    
    ' get custom properties into array, then delete
    For Each docCustomProperty In ActiveDocument.CustomDocumentProperties
'        Debug.Print docCustomProperty.Name & " value " & docCustomProperty.Value
        ' don't recreate 'sharepoint' type custom properties - ContentType, ContentTypeID
        If InStr(1, docCustomProperty.Name, "contenttype", vbTextCompare) Then
'            Debug.Print "found contenttype property: " & docCustomProperty.Name
        Else
            ReDim Preserve arrCustomDocProps(UBound(arrCustomDocProps) + 1)
            arrCustomDocProps(UBound(arrCustomDocProps)) = docCustomProperty.Name & "^" & docCustomProperty.Value
        End If
        ' uncomment to delete the custom property
'        docCustomProperty.delete
        intDeleted = intDeleted + 1
    Next docCustomProperty
    
    ' sort custom properties alphabetically
    Quicksort arrCustomDocProps, LBound(arrCustomDocProps), UBound(arrCustomDocProps)
    
    ' recreate custom properties from array
    For varCounter = 1 To UBound(arrCustomDocProps)
'        Debug.Print "item: " & varCounter & " " & arrCustomDocProps(varCounter)
'        Debug.Print Split(arrCustomDocProps(varCounter), "^")(0)
'        Debug.Print Split(arrCustomDocProps(varCounter), "^")(1)
        If InStr(1, Split(arrCustomDocProps(varCounter), "^")(0), "date", vbTextCompare) Then
'            Debug.Print "found date property: " & Split(arrCustomDocProps(varCounter), "^")(0)
            updateCustomDocumentProperty (Split(arrCustomDocProps(varCounter), "^")(0)), (Split(arrCustomDocProps(varCounter), "^")(1)), msoPropertyTypeDate
        Else
            updateCustomDocumentProperty (Split(arrCustomDocProps(varCounter), "^")(0)), (Split(arrCustomDocProps(varCounter), "^")(1)), msoPropertyTypeString
        End If
        intCreated = intCreated + 1
    Next varCounter
    
    Set docCustomProperty = Nothing
    Set varCounter = Nothing
    Erase arrCustomDocProps
    
    Debug.Print "deleted " & intDeleted & " and recreated " & intCreated & " custom document properties"
End Sub

Private Sub Quicksort(vArray As Variant, arrLbound As Long, arrUbound As Long)
'
' Sorts a one-dimensional VBA array from smallest to largest
' using a very fast quicksort algorithm variant.
'
' https://wellsr.com/vba/2018/excel/vba-quicksort-macro-to-sort-arrays-fast/
'
    Dim pivotVal As Variant, vSwap As Variant
    Dim tmpLow As Long, tmpHi As Long
     
    tmpLow = arrLbound
    tmpHi = arrUbound
    pivotVal = vArray((arrLbound + arrUbound) \ 2)
     
    While (tmpLow <= tmpHi) 'divide
        While (vArray(tmpLow) < pivotVal And tmpLow < arrUbound)
            tmpLow = tmpLow + 1
        Wend
      
        While (pivotVal < vArray(tmpHi) And tmpHi > arrLbound)
            tmpHi = tmpHi - 1
        Wend
     
        If (tmpLow <= tmpHi) Then
            vSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = vSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend
     
    If (arrLbound < tmpHi) Then Quicksort vArray, arrLbound, tmpHi 'conquer
    If (tmpLow < arrUbound) Then Quicksort vArray, tmpLow, arrUbound 'conquer
    
    Set pivotVal = Nothing
    Set vSwap = Nothing
End Sub

Private Sub updateCustomDocumentProperty(strPropertyName As String, varValue As Variant, docType As Office.MsoDocProperties)
'
' updates custom document property, creates it if it doesn't exist
'
' https://stackoverflow.com/questions/14863250/how-to-add-a-documentproperty-to-customdocumentproperties-in-excel
'
    On Error Resume Next
    ActiveDocument.CustomDocumentProperties(strPropertyName).Value = varValue
    If Err.Number > 0 Then
        ActiveDocument.CustomDocumentProperties.Add _
            Name:=strPropertyName, _
            LinkToContent:=False, _
            Type:=docType, _
            Value:=varValue
    End If
End Sub

Sub Sort_Custom_Document_Properties()
Dim DocProp As DocumentProperty, CustPropArr() As String
ReDim Preserve CustPropArr(0): CustPropArr(0) = ""
' Add Custom Document Properties to Array
For Each DocProp In ActiveDocument.CustomDocumentProperties
  With DocProp
    If InStr(1, .Name, "contenttype", vbTextCompare) = 0 Then
      ReDim Preserve CustPropArr(UBound(CustPropArr) + 1)
      CustPropArr(UBound(CustPropArr)) = .Name & "|" & .Type & "|" & .Value
    End If
  End With
Next DocProp
WordBasic.SortArray CustPropArr
MsgBox Join(CustPropArr, vbCr)
End Sub

Sub Sort_Custom_Document_Properties()
Dim DocProp As DocumentProperty, CustPropArr() As String, i As Long
ReDim Preserve CustPropArr(0): CustPropArr(0) = ""
With ActiveDocument
  For Each DocProp In .CustomDocumentProperties
    With DocProp
      If InStr(1, .Name, "contenttype", vbTextCompare) = 0 Then
        ReDim Preserve CustPropArr(UBound(CustPropArr) + 1)
        CustPropArr(UBound(CustPropArr)) = .Name & "|" & .Type & "|" & .Value & "|" & .LinkToContent & "|" & .LinkSource
      End If
    End With
  Next DocProp
  For i = 1 To UBound(CustPropArr)
    .CustomDocumentProperties(Split(CustPropArr(i), "|")(0)).Delete
  Next
  WordBasic.SortArray CustPropArr
  For i = 1 To UBound(CustPropArr)
    .CustomDocumentProperties.Add _
      Name:=Split(CustPropArr(i), "|")(0), _
      Type:=Split(CustPropArr(i), "|")(1), _
      Value:=Split(CustPropArr(i), "|")(2), _
      LinkToContent:=Split(CustPropArr(i), "|")(3), _
      LinkSource:=Split(CustPropArr(i), "|")(4)
    CustPropArr(i) = Split(CustPropArr(i), "|")(0)
  Next
End With
MsgBox "The following Custom Document Properties have been sorted:" & vbCr & Join(CustPropArr, vbCr)
End Sub