Having trouble with the below code I've written. It should be updating the entries of a graph that previously ran from DL5:HX5 to DL5:IU5, have around 100 sheets hence the loop. For some reason it's stepping through but I appear to have a semantic error. Was hoping somebody might shed some light as to what that was.
There are three figures, and I'm not sure this is the best way to access figures on multiple sheets (they're identical copies of one another, with different data.) The first two just extends the time series the additional columns (e.g. HX to IU), the last figure simply color formats a line to a different color (the line is split by projected and actual line fragments.)
Dim i As Integer
For i = 31 To ActiveWorkbook.Worksheets.Count
On Error Resume Next
Worksheets(i).ChartObjects("Chart 2").Activate
ActiveChart.SeriesCollection(1).Values = "='" & Worksheets(i).Name & "'!$DL$5:$IU$5"
ActiveChart.SeriesCollection(1).XValues = "='" & Worksheets(i).Name & "'!$DL$3:$IU$3"
Worksheets(i).ChartObjects("Chart 6").Activate
ActiveChart.SeriesCollection(1).Values = "='" & Worksheets(i).Name & "'!$DL$14:$IU$14"
ActiveChart.SeriesCollection(2).Values = "='" & Worksheets(i).Name & "'!$DL$15:$IU$15"
ActiveChart.SeriesCollection(3).Values = "='" & Worksheets(i).Name & "'!$DL$16:$IU$16"
ActiveChart.SeriesCollection(3).XValues = "='" & Worksheets(i).Name & "'!$DL$3:$IU$3"
Worksheets(i).ChartObjects("Chart 1").Activate
ActiveChart.SeriesCollection(1).Points(30).Border.Color = RGB(69, 114, 167)
ActiveChart.SeriesCollection(1).Points(30).Format.Line.ForeColor.RGB = RGB(69, 114, 167)
Next i
You should avoid activating/selecting where you can. Untested:
Sub Tester()
Dim i As Integer
Dim sht As Worksheet
For i = 31 To ActiveWorkbook.Worksheets.Count
Set sht = ActiveWorkbook.Sheets(i)
With sht.ChartObjects("Chart 2").Chart.SeriesCollection(1)
.Values = sht.Range("$DL$5:$IU$5")
.XValues = sht.Range("$DL$3:$IU$3")
End With
With sht.ChartObjects("Chart 6").Chart
.SeriesCollection(1).Values = sht.Range("$DL$14:$IU$14")
.SeriesCollection(2).Values = sht.Range("$DL$15:$IU$15")
.SeriesCollection(3).Values = sht.Range("$DL$16:$IU$16")
.SeriesCollection(3).XValues = sht.Range("$DL$3:$IU$3")
End With
With sht.ChartObjects("Chart 1").Chart.SeriesCollection(1).Points(30)
.Border.Color = RGB(69, 114, 167)
.Format.Line.ForeColor.RGB = RGB(69, 114, 167)
End With
Next i
End Sub
EDIT: renaming charts
For i = 31 To ActiveWorkbook.Worksheets.Count
With ActiveWorkbook.Sheets(i)
on error resume next
.chartobjects("Chart 13").Name = "Chart 2"
on error goto 0
End With
Next i
Related
I'm stuck with a macro and I can't find a solution.
I need to create a pie chart and I created a sub for that, but when I call this macro excel crashes.
However if I use the developer tab and go through using F8 button it does not crash.
Any idea?
Here is the code:
Sub create_pie_chart()
Dim ws1, ws2 As Worksheet
Dim r, c As Integer
Dim path, pathopti, main_file, thismonth, lymonth As String
path = ThisWorkbook.path
pathraw = path & "\raw\"
pathopti = path & "\optimized\"
main_file = path & "Main_reporting.xlsm"
thismonth = ThisWorkbook.Sheets("Main dashboard").Cells(3, 5).Value
lymonth = ThisWorkbook.Sheets("Main dashboard").Cells(4, 5).Value
Set ws1 = ActiveWorkbook.Worksheets("World Family")
thismonth = ThisWorkbook.Sheets("Main dashboard").Cells(3, 5).Value
r = Range(Range("A1"), Range("A1").End(xlDown)).Rows.count
Application.ScreenUpdating = False
ActiveSheet.Shapes.AddChart2(251, xlPie).Select
With ActiveChart
.SetSourceData Source:=Sheets("World Family").Range("A3:B" & r), PlotBy:=xlColumns
.ClearToMatchStyle
.ApplyLayout (2)
.ChartStyle = 259
.ChartTitle.Text = "Values for " & thismonth
.SeriesCollection(1).Explosion = 10
End With
ActiveSheet.Shapes.AddChart2(251, xlPie).Select
With ActiveChart
.SetSourceData Source:=Sheets("World Family").Range("A3:A" & r & ",F3:F" & r), PlotBy:=xlColumns
.ClearToMatchStyle
.ApplyLayout (2)
.ChartStyle = 259
.ChartTitle.Text = "Units for " & thismonth
.SeriesCollection(1).Explosion = 10
End With
Application.ScreenUpdating = True
End Sub
Apologies, the Title is slightly misleading. Rather than switch the row/column (select a graph, then on the design tab, click "Switch Row/Column") in excel, I would like to force it initially, mitigating the need to change.
My code is as below, adding another column the rows/columns have switched automatically:
Sub InsertBar(rngToPrint As Range, lngTopleft As String, BottomLeft As String)
Dim strRange As String
Dim rngChart As Range
Dim myChart As Chart
lngStartRow = Sheets(rngToPrint.Worksheet.Name).Range(lngTopleft).Row
lngEndRow = Sheets(rngToPrint.Worksheet.Name).Range(BottomLeft).Row
Sheets(rngToPrint.Worksheet.Name).Activate
'Correct
'Sheets(rngToPrint.Worksheet.Name).Range("$A$" & CStr(lngStartRow) & ":$D$" & CStr(lngEndRow)).Select
'Shows Flipped Axis
Sheets(rngToPrint.Worksheet.Name).Range("$A$" & CStr(lngStartRow) & ":$E$" & CStr(lngEndRow)).Select
Set myChart = ActiveSheet.Shapes.AddChart(xlColumnClustered, 500, 10, , 175).Chart
With myChart
.ChartArea.Format.TextFrame2.TextRange.Font.Size = 8
.HasTitle = True
.ChartTitle.Text = rngToPrint.Worksheet.Name & " Receiving Sim Stats - (Today Only)"
.SeriesCollection(1).Name = Range("B" & lngStartRow - 1).Value
.SeriesCollection(2).Name = Range("C" & lngStartRow - 1).Value
.SeriesCollection(3).Name = Range("D" & lngStartRow - 1).Value
'Dataseries which has just been added
.SeriesCollection(4).Name = Range("E" & lngStartRow - 1).Value
End With
End Sub
For anyone else interested, the answer I found in the end was this:
With myChart
.PlotBy = xlColumns
Or if you would like to switch this the other way:
myChart.PlotBy = xlRows
I am working with this macro that will look at a block of transactions, insert 3 rows between months, and then add the month and subtotal. The issue is that the break and totals are getting inserted at the beginning of the month instead of the end.
I have tried to adjust the shift but it either ends up giving me an error or the total ends up overriding an existing cell instead of going into a new row. This is a more complex macro than I have worked with before and I'm a little lost now, still working on learning VBA.
Option Explicit
Sub AddAndSum()
On Error GoTo lblError
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim shData As Worksheet, wbData As Workbook
Dim fr As Long, lr As Long, i As Long, lr2 As Long
Dim intMonth As Long, intYear As Long
Set wbData = ThisWorkbook
Set shData = wbData.Sheets("Sheet1")
fr = 13
lr = shData.Rows.Count
For i = fr To lr
With shData
If (IsDate(.Cells(i, 3).Value) And IsDate(.Cells(i - 1, 3).Value) And Month(.Cells(i, 3).Value) <> Month(.Cells(i - 1, 3).Value)) Or i = fr Then
intMonth = Month(.Cells(i, 3).Value)
intYear = Year(.Cells(i, 3).Value)
.Rows(i & ":" & i + 2).Insert Shift:=xlDown
.Cells(i + 1, 1).Value = "Monthly Total (" & MonthName(intMonth) & ")"
.Cells(i + 1, 2).Formula = "=SUMPRODUCT((MONTH($C$" & fr & ":$C$" & lr & ")=" & intMonth & ")*(YEAR($C$" & fr & ":$C$" & lr & ")=" & intYear & ")*$E$" & fr & ":$E$" & lr & ")"
i = i + 3
End If
End With
Next i
lblError:
If Err.Number <> 0 Then
MsgBox "Error (" & Err.Number & "): " & Err.Description, vbOKOnly + vbCritical
End If
GoTo lblExit
lblExit:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculate
Application.Calculation = xlCalculationAutomatic
Exit Sub
End Sub
This line begins the insertion at Row i.
.Rows(i & ":" & i + 2).Insert Shift:=xlDown
You want to begin the insertion at row i+3, and you can accomplish that with the Offset method:
.Rows(i & ":" & i + 2).Offset(3).Insert Shift:=xlDown
You may also want to see this answer regarding best way of getting the "last row" in a column:
Error in finding last used cell in VBA
As you're currently doing lr = shData.Rows.Count that is 65,336 rows in Excel 2003, or 1,048,576 rows in Excel 2007+ and you almost certainly do not have that many data (otherwise an Insert would fail!), so your loop is cycling needlessly over a bunch of empty rows.
You need to change this row:
intMonth = Month(.Cells(i, 3).Value)
to
intMonth = Month(.Cells(i-1, 3).Value)
At the moment it is setting intMonth to the value of the current cell (which is the first cell of the next month) instead of the value of the previous cell (which contains the month you want to subtotal).
Then add a condition into your loop to add the last subtotal.
Also:
If (IsDate(.Cells(i, 3).Value) And IsDate(.Cells(i - 1, 3).Value) And Month(.Cells(i, 3).Value) <> Month(.Cells(i - 1, 3).Value)) Or i = fr Then
Should this be i = lr ? as you are checking for the last line in the sheet? At the moment will always put a subtotal after the first line. You'll need to update this value when you add the three subtotal lines in as well.
Using this to create a button:-
Sub CreateButton4()
Dim i&
With ActiveSheet
i = .Shapes.Count
With .Buttons.Add(199.5, 20 + 46 * i, 81, 36)
.Name = "New Button" & Format(i, "00")
.OnAction = "MoveValue"
.Characters.Text = "Submit " & Format(i, "00")
End With
End With
That runs the MoveValue() sub:-
Sub MoveValue()
With Sheets("Sheet1").Columns(8).Find(Range("C3").Value, , , 1).Offset(0, 1)
.Value = .Value + Sheets("Sheet1").Range("D3").Value
End With
The problem is I want MoveValue() to relate to the cells adjacent to it as I have another sub which submits data to the adjacent cells when the button is created (at the moment I've only written it to work for the first button). Not sure if I'm going about this completely the wrong way. Any help would be appreciated.
Image Spreadsheet1
You can use the property TopLeftCell as shown here. But you have to change your layout like this, so the top left cell of your button is in the same row as the information you want.
Sub CreateButton4()
Dim i&
With ActiveSheet
i = .Shapes.Count
With .Buttons.Add(199.5, 35 + 46 * i, 81, 36)
.Name = "New Button" & Format(i, "00")
.OnAction = "MoveValue"
.Characters.Text = "Submit " & Format(i, "00")
End With
End With
End Sub
Sub MoveValue()
Dim tlcRow As Integer
tlcRow = ActiveSheet.Shapes(Application.Caller).TopLeftCell.row
With Plan1
.Range("H3:H8").Find(.Range("C" & tlcRow).Value).Offset(0, 1).Value = .Range("D" & tlcRow).Value
End With
End Sub
I hope I make this clear:
I have a loop that copies some hyperlinks in specific cells (they come from a document list with the file path, document name, etc stored in another sheet).
I would like to have an icon next to the hyperlink that indicates if it will open a word document, a folder, etc. In the document list, I can put an indicator in the column next to the hyperlink (1 for word doc, 2 for folder, etc) so that depending on the case, the right icon gets sent next to the right type of document hyperlink.
I have managed to do it by simply inserting shapes (blue rectangle for word doc, green for folder) but I'd like to have a more descriptive symbol (like a specific FaceID maybe?). Here is my code (dumbed down for simplicity):
Sub Icons()
Dim i As Integer
Dim sh As Object
'Only loops through A1:A5 for simplicity
'Looks at the associated indicator located in the previous sheet
'Assigns a shape depending if it is 1 or 2
For i = 1 To 5
If Feuil1.Range("A" & i) = "1" Then
Set sh = Feuil2.Shapes.AddShape(msoShapeRectangle, Range("A"& i).Left, Range("A" & i).Top, 15, 15)
sh.Name = "WordDocIcon" & i
sh.Fill.ForeColor.RGB = RGB(0, 220, 220)
End If
If Feuil1Range("A" & i) = "2" Then
'It is easy to do when inserting a given msoShape, but I want something else!
Set sh = Feuil2.Shapes.AddShape(msoShapeRectangle, Range("A" & i).Left, Range("A" & i).Top, 15, 15)
sh.Name = "FolderIcon" & i
sh.Fill.ForeColor.RGB = RGB(100, 100, 0)
End If
Next
End Sub
Further to my comments, Here is how you can insert pictures and position them in say Column B. I would still say that typing "Word" or "Folder" in Column B and then coloring the cell would be much simpler :)
Sub Sample()
Dim ws As Worksheet
Dim picWord As String
Dim picFolder As String
Dim Shp As Shape
Dim i As Long
picWord = "C:\Users\Siddharth\Desktop\Word.Jpg"
picFolder = "C:\Users\Siddharth\Desktop\folder.Jpg"
Set ws = ThisWorkbook.Sheets("Feuil1")
With ws
For i = 1 To 5
If .Range("A" & i) = "1" Then
With .Pictures.Insert(picWord)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = ws.Range("B" & i).Width
.Height = ws.Range("B" & i).Height
End With
.Left = ws.Range("B" & i).Left
.Top = ws.Range("B" & i).Top
.Placement = 1
.PrintObject = True
End With
ElseIf .Range("A" & i) = "2" Then
With .Pictures.Insert(picFolder)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = ws.Range("B" & i).Width
.Height = ws.Range("B" & i).Height
End With
.Left = ws.Range("B" & i).Left
.Top = ws.Range("B" & i).Top
.Placement = 1
.PrintObject = True
End With
End If
Next i
End With
End Sub
I used the following pictures. You can download these or use whatever you like.
When you run the above code, you will get this kind of output