Trying to put the chart below Sales Value

Eric Penfold

Active Member
Joined
Nov 19, 2021
Messages
424
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
Please help with placing a chart below the word sales thanks in advance

VBA Code:
Option Explicit

Sub DailyMail_Chart_Update()

    Dim wb     As Workbook
    Dim ws     As Worksheet
    Dim dwb    As Workbook
    Dim dws    As Worksheet
    Dim LRow   As Long
    Dim cht1   As ChartObject, cht2 As ChartObject
    Dim Month  As Date
    Dim shape  As Excel.shape
    Dim MyWidth As Single, MyHeight As Single
    Dim chtRng As Range, RngLoop As Range, Cell As Range

    Set wb = Workbooks("MyPersonal.xlsb")
    Set ws = wb.Worksheets("DailyMail")
    Set dwb = Workbooks("DailyMail.xlsx")
    Set dws = dwb.Worksheets("Daily Mail Update")
    LRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set RngLoop = ws.Range("A2:A" & LRow)
    
    With dws
        Set cht1 = .ChartObjects("Daily_Mail_Graph")
        cht1.Activate
        ActiveChart.ChartTitle.Select
        Selection.Characters.Text = Format(Date, "mmmm")
        With Selection.Characters(Start:=1, Length:=30).Font
            .Name = "Arial"
            .FontStyle = "Bold"
            .Size = 16
            ActiveChart.ChartTitle.Left = 300
            ActiveChart.ChartTitle.Top = 0
            dws.ChartObjects("Daily_Mail_Graph").Chart.ChartArea.Copy
            ws.Activate
            With ws
                On Error Resume Next
                .ChartObjects.Delete
                .Paste
            End With
            
            With ws
                Set RngLoop = .Range("A2:A" & LRow)
                For Each Cell In RngLoop
                    If Cell.Value Like "SALES" Then
                        Set cht2 = .ChartObjects("Daily_Mail_Graph")
                        cht2.Top = Cell.Offset(3, 1).Height
                        cht2.Left = Cell.Offset(3, 1).Width
                        cht2.Width = Cell.Offset(3, 15).Width
                        cht2.Height = Cell.Offset(31, 15).Height
                    End If
                Next Cell
            End With
        End With
    End With

End Sub
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
I`ve had a go at this myself (See Below) but finding it very hard to get the chart in to the right position please can somebody help Many Thanks in advance.

This is the part i am sure is wrong because the height on the end does not seem to work?

VBA Code:
cht2.Height = .Range("A" & TRow) & ":" & ("P" & BRow).Height

VBA Code:
Sub DailyMail_Chart_Update()

    Dim wb     As Workbook
    Dim ws     As Worksheet
    Dim dwb    As Workbook
    Dim dws    As Worksheet
    Dim TRow   As Long, BRow As Long
    Dim cht1   As ChartObject, cht2 As ChartObject
    Dim Month  As Date
    Dim shape  As Excel.shape
    Dim MyWidth As Single, MyHeight As Single
    Dim chtRng As Range, RngLoop As Range, Cell As Range

    Set wb = Workbooks("MyPersonal.xlsb")
    Set ws = wb.Worksheets("DailyMail")
    Set dwb = Workbooks("DailyMail.xlsx")
    Set dws = dwb.Worksheets("Daily Mail Update")
 
    Set Cell = Cells(Application.Match("SALES", ws.Range("A:A"), 0), 1)
    TRow = Cell.Row + 3
    BRow = Cell.Row + 31
    Set RngLoop = ws.Range("A2:A" & TRow)
 
 
    With dws
        Set cht1 = .ChartObjects("Daily_Mail_Graph")
        cht1.Activate
        ActiveChart.ChartTitle.Select
        Selection.Characters.Text = Format(Date, "mmmm")
        With Selection.Characters(Start:=1, Length:=30).Font
            .Name = "Arial"
            .FontStyle = "Bold"
            .Size = 16
            ActiveChart.ChartTitle.Left = 525
            ActiveChart.ChartTitle.Top = 0
            dws.ChartObjects("Daily_Mail_Graph").Chart.ChartArea.Copy
            ws.Activate
            With ws
                On Error Resume Next
                .ChartObjects.Delete
                .Paste
                Set cht2 = .ChartObjects("Daily_Mail_Graph")
                cht2.Top = .Range("A1:B" & TRow).Height
                cht2.Left = .Range("A1:B" & TRow).Width
                cht2.Width = .Range("A1:P" & TRow).Width
                cht2.Height = .Range("A" & TRow) & ":" & ("P" & BRow).Height
            End With
        End With
    End With
 
 
 
End Sub
 
Upvote 0

Forum statistics

Threads
1,215,069
Messages
6,122,959
Members
449,096
Latest member
Anshu121

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top