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
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
Is something outdated on msdn (here, in particular https://msdn.microsoft.com/en-us/library/office/ff821866.aspx ), or am I just really dumb? I have some code:
'Cel is a range, CelCol is a long, i, j, k, l are all long, LastColumn is a long, GraphDataStationBlock is a constant (long), wsh1 and wsh2 are worksheets, and chrt is the chart
'option explicit is on so if I missed mentioning a variable, it *was* declared, I just missed it
'I tried setting the source data both before and after all this just in case it mattered but nothing changed
j = 1
For Each Cel In wsh1.Range(wsh1.Cells(GraphDataStationBlock * i + 1, 1), wsh1.Cells(GraphDataStationBlock * (i + 1), 1)).Cells
If Cel.Offset(0, 1) <> vbNullString Then
wsh1.Cells(Cel.Row, CelCol) = WorksheetFunction.Max(wsh2.Range(wsh2.Cells(Cel.Row, 3), wsh2.Cells(Cel.Row, 26)))
chrt.SeriesCollection(j).XValues = wsh1.Range("B3:B5") 'all but straight from the msdn website, still doesn't work!
'I also tried a standard range(cell1, cell2) format (not letter/number) in case that would work but it did not, even though msdn says ranges should be fine
chrt.SeriesCollection(j).name = wsh1.Cells(Cel.Row, 1) & vbSpace & wsh1.Cells(Cel.Row, 2)
'always gives "unable to get name property of the series class"
j = j + 1
End If
Next Cel
'there's a lot more besides this of course but this is just the problematic part
long story short, it copies a row maxima from sheet A (representing hourly data for a single day), puts it into the appropriate column on sheet B (representing each day of that month), and then maps it onto chart C. Or it's supposed to. In practice, it copies the maxima over just fine and then I get an endless series of run-time error 1004, for both the name and the XValues portion of the seriescollection.
I haven't really built all that many charts - namely, none - so I'm kind of blundering around a bit, and if there's a better method of making a chart then I'm all ears, but otherwise...
Edit: the data it's getting this from is pretty straightforward - day numbers (1 to the last day of the month) across the top, labels in the left two columns, and then data that gets filled in each day. Come to think of it, it wouldn't matter that at any given time a fair amount of the source data is empty, right?
Also, more code. This still isn't nearly the entire program, but it covers a lot more than the above loop.
Option Explicit
'vbSpace will be mentioned, I just saved it as a public variable equalling " " because I find it easier to type
Sub UpdateMonthlyGraphData(ByVal wsh2 As Worksheet, ByVal Yesterdate As Date, ByVal FirstDate As Date, ByVal LastDate As Date)
'wsh2 has the daily information
With Excel.Application
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim LastColumn As Long, i As Long, j As Long, SheetCount As Long, CelCol As Long
Dim FirstDay As Long, LastDay As Long, FirstWeekday As Long
Dim Yesteryear As Long, Yestermonth As Long, Yesterday As Long
Dim FormattedMonth As String, ChartType As String
Dim Cel As Range
Dim SerCol As Series
Dim wsh1 As Worksheet
Dim wb1 As Workbook
Dim chrt As Chart
Set wb1 = ThisWorkbook
FirstWeekday = Weekday(FirstDate, vbSunday)
LastDay = Day(LastDate)
FormattedMonth = Format(Yesterdate, "MMM YYYY")
SheetCount = wb1.Sheets.Count
Yesteryear = Year(Yesterdate)
Yestermonth = Month(Yesterdate)
Yesterday = Day(Yesterdate)
LastColumn = 2 + LastDay 'Set the data range to the appropriate size according the number of days in the month
If Not CBool(WorksheetExists(MonthName(Yestermonth, True) & vbSpace & Yesteryear & vbSpace & "Monthly Graph Data")) Then
'WorksheetExists just looks thruogh each worksheet and either returns the index of the sheet named (if it exists) or zero (if not).
SheetCount = wb1.Sheets.Count 'Monthly Data sheet creation
wb1.Worksheets("Template Monthly Graph Data").Copy after:=wb1.Sheets(SheetCount)
SheetCount = SheetCount + 1
Set wsh1 = wb1.Sheets(SheetCount)
wsh1.Move after:=wb1.Worksheets("Template WOT Main")
wsh1.name = MonthName(Yestermonth, True) & vbSpace & Yesteryear & vbSpace & "Monthly Graph Data"
LastDay = Day(DateSerial(Yesteryear, Yestermonth + 1, 0))
For i = 1 To 31 'only sort of tested code, be sure to check in on it to make sure it works properly
If i <= LastDay Then
wsh1.Cells(2, i + 2) = i & " : " & WeekdayName(Weekday(DateSerial(Yesteryear, Yestermonth, i), vbSunday), True)
Else
wsh1.Cells(2, i + 2) = "N/A"
End If
Next i
Else
Set wsh1 = wb1.Worksheets(MonthName(Yestermonth, True) & vbSpace & Yesteryear & vbSpace & "Monthly Graph Data")
LastDay = DateSerial(Yesteryear, Yestermonth + 1, 0)
End If
Set Cel = wsh1.Range(wsh1.Cells(2, 3), wsh1.Cells(2, LastDay + 2)).Cells.Find(Yesterday & " : " & WeekdayName(Weekday(Yesterdate, vbSunday), True))
'importing yesterday's data
If Not Cel Is Nothing Then
Set Cel = wsh1.Cells(GraphDataStationBlock - 3, Cel.Column)
CelCol = Cel.Column
Cel = WorksheetFunction.Max(wsh2.Range(wsh2.Cells(GraphDataStationBlock - 3, 3), wsh2.Cells(GraphDataStationBlock - 3, 26)))
Cel.Offset(1, 0) = WorksheetFunction.Max(wsh2.Range(wsh2.Cells(GraphDataStationBlock - 2, 3), wsh2.Cells(GraphDataStationBlock - 2, 26)))
wsh1.Range(Cel, Cel.Offset(1, 0)).NumberFormat = "0.0"
Else
MsgBox "Monthly Graph Data Sheet did not initialize correctly. Please review code and results."
Exit Sub 'just in case?
End If
For i = 0 To 2
Select Case i
Case 0
ChartType = "Winding"
Case 1
ChartType = "Oil"
Case 2
ChartType = "MW"
End Select
If Not CBool(ChartExists(FormattedMonth & " Monthly " & ChartType & " Graph")) Then 'the chart counterpart to the above "WorksheetExists"
wb1.Charts("Template Monthly " & ChartType & " Graph").Copy after:=wb1.Sheets(SheetCount)
SheetCount = SheetCount + 1
Set chrt = wb1.Sheets(SheetCount)
chrt.name = FormattedMonth & " Monthly " & ChartType & " Graph"
chrt.Move before:=wb1.Worksheets(FormattedMonth & " Monthly Graph Data")
chrt.Legend.Font.Size = 10 'was there before, keep it I guess?
If i < 2 Then
chrt.ChartTitle.Characters.Text = FormattedMonth & vbSpace & ChartType & " Temp Peaks"
Else
chrt.ChartTitle = FormattedMonth & vbSpace & ChartType & " Peaks"
End If
Else
Set chrt = wb1.Charts(FormattedMonth & " Monthly " & ChartType & " Graph")
End If
chrt.SetSourceData Source:=Union(wsh1.Range(wsh1.Cells(GraphDataStationBlock * i + 3, 3), wsh1.Cells(GraphDataStationBlock * i + 2 + Feeders138, LastColumn)), wsh1.Range(wsh1.Cells(GraphDataStationBlock * (i + 1) - Feeders416 - 4, 3), wsh1.Cells(GraphDataStationBlock * (i + 1) - 5, LastColumn))), PlotBy:=xlRows
For Each SerCol In chrt.SeriesCollection
Debug.Print SerCol.ChartType 'this didn't work
Stop 'it'd be convenient if it did, though, and if I can get the code to work at all, I will probably try and make it look all pretty and compact like this
Next SerCol
j = 1
For Each Cel In wsh1.Range(wsh1.Cells(GraphDataStationBlock * i + 1, 1), wsh1.Cells(GraphDataStationBlock * (i + 1), 1)).Cells
If Cel.Offset(0, 1) <> vbNullString Then
wsh1.Cells(Cel.Row, CelCol) = WorksheetFunction.Max(wsh2.Range(wsh2.Cells(Cel.Row, 3), wsh2.Cells(Cel.Row, 26)))
'noted limitation: as is this requires that the order of the feeders in the monthly and daily graph data sheets be structured the same way
chrt.SeriesCollection(j).XValues = wsh1.Range("B3:B5") '"='" & wsh1.name & "'!" & wsh1.Range(wsh1.Cells(2, 3), wsh1.Cells(2, LastColumn)).Address '"='" & Yesterdate & " Graph Data'!R2C3:R2C26"
chrt.SeriesCollection(j).name = wsh1.Cells(Cel.Row, 1) & vbSpace & wsh1.Cells(Cel.Row, 2)
j = j + 1
End If
Next Cel
Next i
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.
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
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