Sub FileCopyTo()
Dim sName As String, sOriginal As String
Dim vPath() As Variant
Dim i As Integer
    vPath = Array("C:\My doc\", "F:\My doc\", "G:\My doc\", "H:\My doc\")
    ActiveDocument.Save
    sOriginal = ActiveDocument.FullName
    sName = ActiveDocument.Name
    For i = 0 To UBound(vPath)
        If FolderExists(CStr(vPath(i))) Then
            ActiveDocument.SaveAs2 FileName:=CStr(vPath(i)) & sName, FileFormat:=wdFormatXMLDocument
        End If
    Next i
    ActiveDocument.SaveAs2 FileName:=sOriginal, FileFormat:=wdFormatXMLDocument
End Sub

Private Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'strFolderName is the name of folder to check
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If (FSO.FolderExists(strFolderName)) Then
        FolderExists = True
    Else
        FolderExists = False
    End If
lbl_Exit:
    Set FSO = Nothing
    Exit Function
End Function