This macro comes from https://wordribbon.tips.net/T011671_Copying_Custom_Properties.html
Sub CopyDocProps()
Dim dp() As DocumentProperty
Dim CustomPropCount As Integer
Dim i As Integer
Dim iResponse As Integer
If Windows.Count > 2 Then
MsgBox "There are more than two windows. Please " & _
"close the others and re-run the macro.", , _
"Too many windows"
Exit Sub
End If
On Error GoTo Err_Handler
iResponse = MsgBox("Are you currently in the source document?", _
vbYesNoCancel, "Copy Custom Properties")
If iResponse = vbNo Then Application.Run MacroName:="NextWindow"
CustomPropCount = ActiveDocument.CustomDocumentProperties.Count
ReDim dp(1 To CustomPropCount)
For i = 1 To CustomPropCount
Set dp(i) = ActiveDocument.CustomDocumentProperties(i)
Next i
Application.Run MacroName:="NextWindow"
For i = 1 To CustomPropCount
If dp(i).LinkToContent = True Then
ActiveDocument.CustomDocumentProperties.Add _
Name:=dp(i).Name, _
LinkToContent:=True, _
Value:=dp(i).Value, _
Type:=dp(i).Type, _
LinkSource:=dp(i).LinkSource
Else
ActiveDocument.CustomDocumentProperties.Add _
Name:=dp(i).Name, _
LinkToContent:=False, _
Value:=dp(i).Value, _
Type:=dp(i).Type
End If
Next i
MsgBox "The properties have been copied."
Exit Sub
Err_Handler:
' if Word raises an error, then allow the user
' to update the custom document property
iResponse = MsgBox("The custom document property (" & _
dp(i).Name & ") already exists." & vbCrLf & vbCrLf & _
"Do you want to update the value?", vbYesNoCancel, _
"Copy Custom Properties")
Select Case iResponse
Case vbCancel
End
Case vbYes
ActiveDocument.CustomDocumentProperties(dp(i).Name).Value _
= dp(i).Value
Resume Next
Case vbNo
Resume Next
End Select
End Sub