Insert a Chart Built in a Workbook Into Another Workbook

Insert a Chart Built in a Workbook Into Another Workbook

Insert into allocated Cells region in a workbook resulted charts built in a different workbook, Can this be done? How would you integrate that chart into some kind of place holder in the workbook that is expecting to get that chart

 Sub CopyChart()  
 ' Copy Chart 'Chart 1' from ThisWorkbook Worksheet 'Sheet1'  
 ' to Workbook 'BookB.xlsm' Worksheet 'Sheet1',  
 ' at specified position.  
 '--  
 Dim wbkSource As Workbook  ' Source Workbook  
   Dim wksSource As Worksheet  ' Source Worksheet  
 ' Top-Left cell where Chart is going to be pasted  
   Dim cSourceTopLeft As Range  
   Dim sTargetTopLeft As String  ' Chart Top-Left cell address  
   '--  
 Dim wbkTarget As Workbook  ' Target Workbook  
   Dim wksTarget As Worksheet  ' Target Worksheet  
   ' Top-Left cell where Chart is going to be pasted  
   Dim cTargetTopLeft As Range  
   Dim sFileNameTarget As String  
   '--  
 Dim oChart As Excel.Chart  
   Dim oChartObject As Excel.ChartObject  
   ' Follows original Chart dimension variables  
   Dim h As Single   ' Chart Heihgt  
   Dim w As Single   ' Chart Width  
   ' Customize the following constant  
   ' (the of increase / decrease of chart (%))  
   'Const csngRATIO As Single = 15 ' = increase 15%  
   ' 0r...  
   Const csngRATIO As Single = -10  ' = decrease 10%  
   '--  
 ' Name of original chart can be seen in Name Box.  
   Const csCHARTNAME As String = "Chart 1"  
   '--  
 ' Customize path and file name  
   ' In this example, my chart is embeded in  
   ' 'ThisWorkbook' = CodeName of Workbook where is stored this vba code  
   '--  
   ' Reference workbooks and worksheets  
   Set wbkSource = ThisWorkbook  
   Set wksSource = wbkSource.Worksheets("Sheet1")  
   With wksSource  
     ' Reference specified Chart  
     Set oChart = .ChartObjects("Chart 1").Chart  ' Reference Chart by Name  
     ' or aaa  
     Set oChart = .ChartObjects(1).Chart  ' Reference Chart by Index  
     sTargetTopLeft = oChart.Parent.TopLeftCell.Address  
     ' It's the same as:  
     'sTargetTopLeft = .ChartObjects(1).TopLeftCell.Address  
     'MsgBox sTargetTopLeft  
     h = oChart.Parent.Height  
     w = oChart.Parent.Width  
   End With  
   ' Reference Workbook 'BookB.xlsm' (where Chart is going to be pasted)  
   ' a) Try reference Workbook if is already open  
   On Error Resume Next  
   Set wbkTarget = Workbooks("BookB.xlsm")  
   If wbkTarget Is Nothing Then  
     ' b) If workbook is not open, then open it  
     ' b2) Construct workbook full name (Path+filename)  
     ' In this example, workbook 'BookB.xlsm' is saved in the same  
     ' folder as 'BookA.xlsm'. Customize path.  
     sFileNameTarget = wbkSource  
     ' Check if top right character is application path separator  
     If Right(sFileNameTarget, 1) <> Application.PathSeparator Then  
       sFileNameTarget = sFileNameTarget & _  
                Application.PathSeparator  
     End If  
     sFileNameTarget = sFileNameTarget & "BookB.xlsm" ' Add File name  
     ' If Workbook is not open (a Is Nothing), then open workbook  
     Set wbkTarget = Workbooks.Open(Filename:=sFileNameTarget)  
   End If  
   '--  
   ' Final check if 'BookB.xlsm' referenced  
   If wbkTarget Is Nothing Then  
     MsgBox "Workbook 'BookB.xlsm' open problem." & vbLf & _  
         "Please check path and file name...", _  
         vbExclamation, "Open BookB "  
     Exit Sub  '>>> Stop execution <<<  
   End If  
   On Error GoTo 0  
   ' Reference Target range (customize reference)  
   Set wksTarget = wbkTarget.Worksheets("Sheet1")  
   With wksTarget  
     ' Reference Target Top-Left cell  
     Set cTargetTopLeft = .Range(sTargetTopLeft) ' The same place as original  
     ' or your customized address  
     Set cTargetTopLeft = .Range("E3")  
   End With  
   wbkTarget.Activate  
   wksTarget.Select  
   cTargetTopLeft.Select  
   Application.ScreenUpdating = False  
   ' Delete previously Target Chart at the same  
   ' position only (if exists).  
   On Error Resume Next  
   For Each oChartObject In wksTarget.ChartObjects  
     ' If the same Top-Left cell address,  
     ' then delete Chart  
     If oChartObject.TopLeftCell.Address = _  
       cTargetTopLeft.Address Then  
       oChartObject.Delete  
       Exit For  '>>>  
     End If  
   Next  
   On Error GoTo 0  
   '++++++++++++++++++++++++++++++  
   ' Copy ChartArea  
   oChart.ChartArea.Copy  
   ' Paste at Target worksheet  
   ActiveSheet.Paste  
   '++++++++++++++++++++++++++++++  
   For Each oChartObject In wksTarget.ChartObjects  
     ' If the Top-Left cell address = 'A1' then  
     ' make the same Chart position as original.  
     ' You can define explicit values for Left and Top  
     ' Chart position, or use Top-Left value of  
     ' any cell, e.g.: oChartObject.Left = Eange("C3").Left  
     If oChartObject.TopLeftCell.Address = "$A$1" Then  
       oChartObject.Left = cTargetTopLeft.Left  
       oChartObject.Top = cTargetTopLeft.Top  
       ' A copy of the chart may not be the same size  
       ' like the original.  
       oChartObject.Width = w * (100 + csngRATIO) / 100  
       oChartObject.Height = h * (100 + csngRATIO) / 100  
       Exit For  '>>>  
     End If  
   Next  
   ' Save Target workbook  
   wbkTarget.Save  
   Application.ScreenUpdating = True  
   cTargetTopLeft.Select  
   MsgBox "Over..." & vbLf & "Copy of Chart is " & _  
       IIf(csngRATIO > 0, "increased", "reduced") & " " & _  
       Format(Abs(csngRATIO) / 100, "0.00%"), _  
       vbInformation, "Copy Chart"  
   ' Release Object variables from memory  
   Set wbkSource = Nothing  
   Set wbkTarget = Nothing  
 End Sub