CODEWITHSUNDEEP
vbaloopsif-statement
Monzonit
Monzonit

Reputation: 1

Loop through sheets and copy Charts to Word, VBA

I'm trying to write a macro that loops through all sheets in a excel workbook and if there is a chart It copy the chart to a new word document. The workbook consist of around 35 sheets and only half of them are populated with a chart. I want the code to jump to next sheet if there is no chart in it and if there is a chart copy it to Word and then move on to the next one. I am very new to VBA and coding in general and been experimenting a bit. I managed to get one chart from one sheet into word... I've tried a few different things and left that in as comments.

My code as today:


        'Declare word object variables
    Dim WordApp     As Word.Application
    Dim WordDoc     As Word.Document
    
        'Declare excel Object variable
    Dim WrkSht      As Worksheet
    Dim Chrt        As ChartObject
    Dim Cht_Sht     As Chart
    Dim wkBk        As Workbook
    
    
    'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False
    
        'Set the link to the location where the excel evaluation sheet is located, include file name in the link
   Const Utvärdering As String = "C:\Users\A561004\OneDrive - AF\Desktop\Test\Utvärdering.xlsx"
    
        'Open Excel Utvärdering...
    Application.StatusBar = "Utvärdering"
    Set wkBk = Workbooks.Open(Utvärdering)
    
        ' Select sheet based on name
    Sheets(1).Select
         
            
        'Create a new instance of Word
    Set WordApp = New Word.Application
        WordApp.Visible = True
        WordApp.Activate
        
        
        'Create a new word document
    Set WordDoc = WordApp.Documents.Add
            
            
        'Start a loop
        For Each WrkSht In Sheets
        'WrkSht.ChartObjects.Select
        
       If ActiveSheet.ChartObjects.Count > 0 Then
        
        For Each Cht_Sht In wkBk.Sheets(1).ChartObjects
            Cht_Sht.ChartArea.ChartArea.Copy
        
        'ActiveChart.ChartArea.Select
        'ActiveChart.ChartArea.Copy
        
            With Word.Application.Selection
       .PasteSpecial Link:=False, DataType:=15
       
           WordApp.ActiveDocument.Selections.Add
        'Go to new page
    WordApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
        'Clear Clipboard
    Application.CutCopyMode = False
       
     End With
     
     Next Cht_Sht
    
        
    Else
        WrkSht.Next.Activate
    End If
        
        'Test loop
        'For each Cht_Sht in 2 To Sheets(ActiveWorkbook.Sheets.Count - 1)
        
     
    
        'Create a Reference to the chart you want to Export
    'ActiveChart.ChartArea.Select
    'On Error Resume Next
    'ActiveChart.ChartArea.Copy
    
    
    
        
        'Paus application 2 sek
    Application.Wait Now + #12:00:02 AM#
        
        
        'Paste into WOrd Document
    'With Word.Application.Selection
     '  .PasteSpecial Link:=False, DataType:=15
       
    ' End With
    
        'New word page Problems here, need to set a new marker in the document for next paste
   ' WordApp.ActiveDocument.Selections.Add
        'Go to new page
  '  WordApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
        'Clear Clipboard
  ' Application.CutCopyMode = False
    
        'End loop, or start next rotation of loop
        Next WrkSht
        
        'Optimise Code
    Application.EnableEvents = True
    
    On Error GoTo 0
    
End Sub

I'm sorry if it is a bit messy.

Upvotes: 0

Views: 310

Answers (2)

ENIAC
ENIAC

Reputation: 1040

You traverse through all sheets (For Each WrkSht In Sheets) but always check only first sheet: For Each Cht_Sht In wkBk.Sheets(1).ChartObjects. You should look for For Each Cht_Sht In wrkSht.ChartObjects instead.

Upvotes: 1

Sarfaraz78615
Sarfaraz78615

Reputation: 124

You missed to type WrkSht.Select right after the For Each WrkSht In Sheets and remove the else condition here is the updated code

For Each WrkSht In Sheets
    WrkSht.Select
    If WrkSht.ChartObjects.Count > 0 Then
        For Each Cht_Sht In wkBk.Sheets(1).ChartObjects
            Cht_Sht.ChartArea.ChartArea.Copy
             With Word.Application.Selection
                 .PasteSpecial Link:=False, DataType:=15
                 WordApp.ActiveDocument.Selections.Add
                 WordApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
                 Application.CutCopyMode = False
             End With
        Next Cht_Sht
    End If
 Next WrkSht

Please mark as answer & closed the thread, if you get the desired answer.

Upvotes: 1

Related Questions