I had similar problem, but wanted also to copy background of a page. Therefore I added the following line in CopyPage procedure:

DestPage.Background = CopyPage.Background

And added another loop over CurrDoc.Pages in MergeDocuments procedure:

For Each CurrPage In CurrDoc.Pages
    Set CurrDestPage = DestDoc.Pages(CurrPage.Name)
    SetBackground CurrPage, CurrDestPage
Next CurrPage

The procedure SetBackground is very simple:

Sub SetBackground(CopyPage As Visio.Page, DestPage As Visio.Page)
   If Not CopyPage.BackPage Is Nothing Then
       DestPage.BackPage = CopyPage.BackPage.Name
   End If
End Sub

And this worked. Maybe sb will find it useful.

Thanks all for sharing a solution.

Let me copy/paste the "merge" of Jon's solution and user26852's addition :-)

This is the full macro that worked like a charm for me:

Private Sub TryMergeDocs()
    Dim Docs() As Variant
    Docs = Array("C:\Tmp\JunkVSD\Drawing1.vsd", "C:\Tmp\JunkVSD\Drawing2.vsd", "C:\Tmp\JunkVSD\Drawing3.vsd")
    MergeDocuments Docs
End Sub

Sub MergeDocuments(FileNames() As Variant, Optional DestDoc As Visio.Document)
    ' merge into a new document if no document is provided
    On Error GoTo PROC_ERR
    If DestDoc Is Nothing Then
        Set DestDoc = Application.Documents.Add("")
    End If

    Dim CheckPage As Visio.Page
    Dim PagesToDelete As New Collection
    For Each CheckPage In DestDoc.Pages
        PagesToDelete.Add CheckPage
    Next CheckPage
    Set CheckPage = Nothing

    ' loop through the FileNames array and open each one, and copy each page into destdoc
    Dim CurrFileName As String
    Dim CurrDoc As Visio.Document
    Dim CurrPage As Visio.Page, CurrDestPage As Visio.Page
    Dim CheckNum As Long
    Dim ArrIdx As Long
    For ArrIdx = LBound(FileNames) To UBound(FileNames)
        CurrFileName = CStr(FileNames(ArrIdx))
        Set CurrDoc = Application.Documents.OpenEx(CurrFileName, visOpenRO)
        For Each CurrPage In CurrDoc.Pages
            Set CurrDestPage = DestDoc.Pages.Add()
            With CurrDestPage
                On Error Resume Next
                Set CheckPage = DestDoc.Pages(CurrPage.Name)
                If Not CheckPage Is Nothing Then
                    While Not CheckPage Is Nothing ' handle duplicate names by putting (#) after the original name
                        CheckNum = CheckNum + 1
                        Set CheckPage = Nothing
                        Set CheckPage = DestDoc.Pages(CurrPage.Name & "(" & CStr(CheckNum) & ")")
                    Wend
                    CurrDestPage.Name = CurrPage.Name & "(" & CStr(CheckNum) & ")"
                Else
                    CurrDestPage.Name = CurrPage.Name
                End If
                On Error GoTo PROC_ERR
                Set CheckPage = Nothing
                CheckNum = 0

                ' copy the page contents over
                CopyPage CurrPage, CurrDestPage
                SetBackground CurrPage, CurrDestPage

            End With

            DoEvents
        Next CurrPage
        DoEvents
        Application.AlertResponse = 7

        CurrDoc.Close
    Next ArrIdx

    For Each CheckPage In PagesToDelete
        CheckPage.Delete 0
    Next CheckPage

PROC_END:
    Application.AlertResponse = 0
    Exit Sub

PROC_ERR:
    MsgBox Err.Number & vbCr & Err.Description
    GoTo PROC_END
End Sub

Sub CopyPage(CopyPage As Visio.Page, DestPage As Visio.Page)
    Dim TheSelection As Visio.Selection
    Dim CurrShp As Visio.Shape
    DoEvents
    Visio.Application.ActiveWindow.DeselectAll

    DestPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).Formula = CopyPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).ResultIU
    DestPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).Formula = CopyPage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).ResultIU
    DestPage.Background = CopyPage.Background


    Set TheSelection = Visio.ActiveWindow.Selection

    For Each CurrShp In CopyPage.Shapes
        TheSelection.Select CurrShp, visSelect
        DoEvents
    Next

    TheSelection.Copy visCopyPasteNoTranslate
    DestPage.Paste visCopyPasteNoTranslate

    TheSelection.DeselectAll
End Sub

Sub SetBackground(CopyPage As Visio.Page, DestPage As Visio.Page)
   If Not CopyPage.BackPage Is Nothing Then
       DestPage.BackPage = CopyPage.BackPage.Name
   End If
End Sub

One thing though: I had to re-check "lock" on a layer I had on my pages. I assume the "layer properties" do not get propagated by the Macro. For me that wasn't a big deal to re-lock all my background layers. But for someone else it might be worth it to look a little bit further on how to copy/paste the layer properties too.

I ran into this issue, and overcame the problem using the Insert Object function.

• Select 'Insert' from the toolbar
• Select 'Object' from the drop down menu
• Select 'Create from file'
• Select 'Microsoft Office Visio Drawing'
• Select 'Link to file'
• Click on 'Browse'
• Select the file you want to insert
• Click 'Open'
• Click 'OK'

The VSD file will be inserted as a picture, that can be updated by opening the original file, or by double clicking and opening Visio for the 'Object'.

Download Visio Super Utilities from:

The installation is given the install_readme.txt in the downloaded package. Please refer to the installation. After Visio Super Utilities is installed, use the following steps to combine Visio documents

1. Open the 2 Visio documents you wish to combine.
2. Go to Add-Ins -> SuperUtils -> Document -> Copy Document to other Document

Repeat this for each source document.

Thanks for the extremly helpful script. I added some lines, to make the script more compatible with the process engineering addon. (This gets activated if you are drawing pipes and valves and stuff with visio) In order to disable automatic numbering or tagging when running the vba-script add the following lines at the beginning:

' Disable PE automatic editing while copying
Dim prevPEUserOptions As Integer
Dim PEEnabled As Integer
If  DestDoc.DocumentSheet.CellExists("User.PEUserOptions", 1) Then
    PEEnabled = 1
    prevPEUserOptions = DestDoc.DocumentSheet.Cells("User.PEUserOptions")
    DestDoc.DocumentSheet.Cells("User.PEUserOptions") = 0
End If

and these at the end:

If (PEEnabled) Then
    DestDoc.DocumentSheet.Cells("User.PEUserOptions") = prevPEUserOptions
End If

I think you will only need this, if you are running the script with an already existing document as target. Perhaps somebody else will find this helpful.