The procedure ImportWorksheetsFromClosedWorkbook() may be used to copy all worksheets from one workbook (source) into a different workbook (target). The procedure also removes all references to external workbooks. This procedure may be useful if the target workbook has a series of predefined charts or pivot tables that rely on data contained in an external workbook published by another entity.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | Option Explicit Sub ImportWorksheetsFromClosedWorkbook() Dim wbSource As Workbook Dim wbTarget As Workbook Dim strFilename As String Dim strOriginalActiveWsName As String Dim bIsFileOpen As Boolean Dim objDefinedName As Object Dim bEnableEvents As Boolean Dim bDisplayAlerts As Boolean Dim bScreenUpdating As Boolean Dim i As Long bEnableEvents = Application.EnableEvents bDisplayAlerts = Application.DisplayAlerts bScreenUpdating = Application.ScreenUpdating Application.EnableEvents = False Application.DisplayAlerts = False Application.ScreenUpdating = False Set wbTarget = ActiveWorkbook strOriginalActiveWsName = wbTarget.ActiveSheet.Name strFilename = "c:\test.xlsx" If Not IsFileExist(strFilename) Then MsgBox "File not found: " & strFilename Exit Sub End If If IsWbOpen(strFilename) Then Set wbSource = Workbooks(strFilename) bIsFileOpen = True Else Set wbSource = Workbooks.Open(strFilename) bIsFileOpen = False End If For i = 1 To wbSource.Sheets.Count On Error Resume Next If Not wbTarget.Sheets(wbSource.Sheets(i).Name) Is Nothing Then wbTarget.Sheets(wbSource.Sheets(i).Name).Delete End If On Error GoTo 0 Next For Each objDefinedName In wbTarget.Names objDefinedName.Delete Next objDefinedName For i = 1 To wbSource.Sheets.Count wbSource.Sheets(i).Copy After:=wbTarget.Sheets(wbTarget.Sheets.Count) Next If Not bIsFileOpen Then wbSource.Close False Call BreakExternalReferences Call DeleteExternalNames wbTarget.Sheets(strOriginalActiveWsName).Activate MsgBox "Source file successfully copied to this workbook." Application.ScreenUpdating = bScreenUpdating Application.DisplayAlerts = bDisplayAlerts Application.EnableEvents = bEnableEvents Set wbTarget = Nothing Set wbSource = Nothing End Sub Function IsFileExist(wbName As String) As Boolean IsFileExist = Len(Dir(wbName)) End Function Function IsWbOpen(wbName As String) As Boolean On Error Resume Next IsWbOpen = Len(Workbooks(wbName).Name) On Error GoTo 0 End Function Sub BreakExternalReferences() Dim arLinks As Variant Dim i As Long arLinks = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks) If IsArray(arLinks) Then For i = LBound(arLinks) To UBound(arLinks) ActiveWorkbook.BreakLink Name:=arLinks(i), Type:=xlLinkTypeExcelLinks Next i End If End Sub Sub DeleteExternalNames() Dim objDefinedName As Object For Each objDefinedName In ActiveWorkbook.Names If InStr(objDefinedName.RefersTo, "[") > 0 Then objDefinedName.Delete End If Next objDefinedName End Sub |