I have an table and would like to generate an chart out of it. the problem is I would like to have only the column Values of A, F, G, and H.
I tried seriescollection(1).deletion method,. but I am still getting the column B and C series in my chart.
Could anyone tell me how I can do it.
Any lead would be helpful
Sub chartstatus()
Dim Rng As Range
Dim cht As Object
Set Rng = ActiveSheet.Range("A2:H53")
ThisWorkbook.Sheets("Status").ChartObjects.delete
Set Sh = ActiveSheet.ChartObjects.Add(Left:=650, _
Width:=600, _
Top:=80, _
Height:=250)
Sh.Select
Set cht = ActiveChart
With cht
.SetSourceData Source:=Rng
.ChartType = xlColumnClustered
cht.Axes(xlSecondary).TickLabels.NumberFormat = "0.%"
End With
cht.SeriesCollection(6).Name = " % Missing "
cht.SeriesCollection(7).Name = " % OnTime"
cht.SeriesCollection(8).Name = " % Delayed"
cht.SeriesCollection(6).HasDataLabels = True
cht.SeriesCollection(7).HasDataLabels = True
cht.SeriesCollection(8).HasDataLabels = True
cht.SeriesCollection(1).Format.Fill.ForeColor.RGB = RGB(255, 255, 255) '<~~ Red
cht.HasTitle = True
cht.ChartTitle.Text = "Result "
End Sub
You can combine 2 range into 1 range
Dim Rng As Range
Dim Rng_A As Range
Dim Rng_FH As Range
Set Rng_A = ActiveSheet.Range("A2:A52")
Set Rng_FH = ActiveSheet.Range("F2:H52")
Set Rng = Union(Rng_A, Rng_FH)
Related
I am struggling with the error subscript out of range at the code:
Set wsCondition = wbCondition.Worksheets(2)
This code is run very well on windows but when I try on MacOS the error occurs. I am a newbie to VBA and I completely do not understand why this error occurs.
Thanks in advance for your guys advice.
Option Explicit
Public Sub btn1_Click()
Dim i As Double
Dim N As Double
Dim strKeyWord As String
Dim myCount As Integer
Dim OrderCount As Integer
Dim SubTotal As Range, Country As Range, DisCount As Range, Quantity As Range, ItemName As Range, OrderName As Range, RequiredData As Range
Dim wsOrder As Worksheet
Dim wsResult As Worksheet
Dim wsCondition As Worksheet
Dim wbOrder As Workbook
Dim wbCondition As Workbook
Dim OrderFile As String
Dim ConditionFile As String
'Open Order wb
OrderFile = Application.GetOpenFilename()
Set wbOrder = Workbooks.Open(OrderFile)
Set wsOrder = wbOrder.Worksheets(1)
'Open Condition wb
ConditionFile = Application.GetOpenFilename()
Set wbCondition = Workbooks.Open(ConditionFile)
Set wsCondition = wbCondition.Worksheets(2)
Set wsResult = wbCondition.Worksheets(1)
With wsResult
.Range("A1").Value = "Product code"
.Range("B1").Value = "Order Condition"
.Range("C1").Value = "Order Name"
.Range("D1").Value = "Subtotal"
.Range("E1").Value = "Discount"
.Range("F1").Value = "Quantity"
.Range("G1").Value = "Item Name"
.Range("H1").Value = "Country"
.Range("A1").Characters(1, 12).Font.Bold = True
.Range("B1").Characters(1, 16).Font.Bold = True
.Range("C1").Characters(1, 16).Font.Bold = True
.Range("D1").Characters(1, 12).Font.Bold = True
.Range("E1").Characters(1, 12).Font.Bold = True
.Range("F1").Characters(1, 12).Font.Bold = True
.Range("G1").Characters(1, 12).Font.Bold = True
.Range("H1").Characters(1, 12).Font.Bold = True
.Range("A1").WrapText = True
.Range("B1").WrapText = True
.Range("C1").WrapText = True
.Range("D1").WrapText = True
.Range("E1").WrapText = True
.Range("F1").WrapText = True
.Range("G1").WrapText = True
.Range("H1").WrapText = True
.Range("A1").ColumnWidth = 13
.Range("A1").RowHeight = 17
.Range("B1").ColumnWidth = 12
.Range("B1").RowHeight = 17
.Range("C1").ColumnWidth = 14.5
.Range("C1").RowHeight = 17
.Range("G1").ColumnWidth = 99
.Range("G1").RowHeight = 17
End With
'using the CountA ws function (all non-blanks)
myCount = Application.CountA(wsCondition.Range("A:A"))
For i = 2 To myCount Step 1
strKeyWord = wsCondition.Range("A" & i)
wsOrder.Range("R:R").AutoFilter Field:=1, Criteria1:="=*" & strKeyWord & "*"
If wsOrder.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
Set SubTotal = wsOrder.Range("I2", wsOrder.Range("I" & Rows.Count).End(xlUp))
Set Country = wsOrder.Range("AG2", wsOrder.Range("AG" & Rows.Count).End(xlUp))
Set DisCount = wsOrder.Range("N2", wsOrder.Range("N" & Rows.Count).End(xlUp))
Set Quantity = wsOrder.Range("Q2", wsOrder.Range("Q" & Rows.Count).End(xlUp))
Set OrderName = wsOrder.Range("A2", wsOrder.Range("A" & Rows.Count).End(xlUp))
Set ItemName = wsOrder.Range("R2", wsOrder.Range("R" & Rows.Count).End(xlUp))
Set RequiredData = Union(SubTotal, Country, DisCount, Quantity, OrderName, ItemName)
RequiredData.SpecialCells(xlCellTypeVisible).Copy
OrderCount = wsOrder.Range("A2", wsOrder.Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Cells.Count
With wsResult
If OrderCount >= 2 Then
For N = 1 To OrderCount Step 1
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = strKeyWord
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = "Available"
Next N
Else
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = strKeyWord
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = "Available"
End If
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).PasteSpecial
End With
Else
With wsResult
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Value = strKeyWord
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value = "No Order"
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).Value = "N/A"
.Cells(.Rows.Count, "D").End(xlUp).Offset(1).Value = "N/A"
.Cells(.Rows.Count, "E").End(xlUp).Offset(1).Value = "N/A"
End With
End If
OrderCount = 0
Next i
wbCondition.Sheets("Result").Activate
wsOrder.AutoFilterMode = False
End Sub
This has nothing to do whether this code is running on a Mac or Win environment. You have to check if a second worksheet exists in the file you open. In your case you could add following code
If wbCondition.Worksheets.Count > 1 Then
Set wsCondition = wbCondition.Worksheets(2)
else
' Do sth in order to fix the error or end the sub
end if
If you get a subscript out of range it means you tried to access a worksheet that doesn’t exist. This may happen for the following reasons
The worksheet name given to Worksheets is spelled incorrectly.
The name of the worksheet has changed. The worksheet was deleted.
The index was to large e.g. You used Worksheets(5) but there are only four worksheets
The wrong workbook is being used e.g. Workbooks(“book1.xlsx”).Worksheets(“Sheet1”) instead of Workbooks(“book3.xlsx”).Worksheets(“Sheet1”)
You find this here
I have several sheets in my workbook which contains data to plot, every time I run a new analysis a new sheet is generated.
On my first sheet I plot all the data in the same graph, so to avoid re plotting all the series every time I append a new sheet I would like to just add a new series.
I thought that should be simple, but it is not for two reasons: When I first create the chart it adds somewhere between 1 and 9 series automatically:
Set myChart = ws.Shapes.AddChart.Chart
myChart.ChartType = xlXYScatterLinesNoMarkers
why does this generate any random series?
also if I delete the graph because I want to rerun one analysis, the graph will then be called 2 and so on... So I tried to give it a name and refer to its name instead, however that does not work:
Set myChart = ws.ChartObjects(ws.Name)
So in the first sheet(Orginal) I plot all data in the workbook, and in the rest I just plot the data for the current sheet as seen below. I use the same code function for both cases, where i just pass the argument all as true(orginal sheet) or false(sheet 1.....300)
Below is the code:
Sub createChart(ws As Worksheet, Optional all As Boolean = False)
Dim lastRow As Long
Dim myChart As Chart
Dim temp As Integer
Dim n As Integer
On Error Resume Next
' Delete the charts, just in case
If ws.ChartObjects.Count > 0 Then ' And Not all Then
ws.ChartObjects.Delete
End If
'If ws.ChartObjects.Count = 0 Then
Set myChart = ws.Shapes.AddChart.Chart
myChart.Name = ws.Name
'Else
'Set myChart = ws.ChartObjects(ws.Name) '''Fails why commented out
'End If
myChart.ChartType = xlXYScatterLinesNoMarkers
myChart.SetElement (msoElementPrimaryCategoryGridLinesMinor)
myChart.SetElement (msoElementPrimaryValueGridLinesMinorMajor)
myChart.SetElement (msoElementLegendBottom)
myChart.SetElement (msoElementChartTitleCenteredOverlay)
myChart.Parent.width = 800 ' px width graph
myChart.Parent.height = 500 ' px height graph
' it adds mysterious sometimes several random series, so we need to delete those that does not match sheet name
For n = myChart.SeriesCollection.Count To 0 Step -1
If Not SheetExists(myChart.SeriesCollection(n).Name) Then
myChart.SeriesCollection(n).Delete
End If
Next n
'*******************************************************************
'**************** FIRST PAGE CHART *********************************
'*******************************************************************
If all Then
Dim wsOther As Worksheet
Dim i As Integer
Dim fixRange As Boolean
Dim skipGraph As Boolean
fixRange = True
myChart.HasLegend = True
myChart.Legend.Position = xlLegendPositionRight
myChart.Parent.Top = 120
myChart.Parent.Left = 450
For Each wsOther In ThisWorkbook.Worksheets
If wsOther.Name <> ws.Name Then
lastRow = getLastRow(wsOther, 1)
skipGraph = False
'******* we only add graphs if it is not before ******************
If myChart.SeriesCollection.Count > 0 Then
For n = myChart.SeriesCollection.Count To 1 Step -1
If myChart.SeriesCollection(n).Name = wsOther.Name Then
skipGraph = True
Exit For
End If
Next n
End If
If Not skipGraph Then
With myChart.SeriesCollection.NewSeries
.Values = "=" & wsOther.Name & "!$E$2:$E$" & lastRow
.Name = wsOther.Name
.XValues = "=" & wsOther.Name & "!$B$2:$B$" & lastRow
End With
End If
If fixRange Then
' Range on axis
myChart.Axes(xlPrimary).MinimumScale = CDate(Application.WorksheetFunction.Min(Range(wsOther.Name & "!$B$2:$B$" & lastRow).Value2))
myChart.Axes(xlPrimary).MaximumScale = CDate(Application.WorksheetFunction.Max(Range(wsOther.Name & "!$B$2:$B$" & lastRow).Value2))
myChart.Axes(xlValue, xlPrimary).ScaleType = xlLogarithmic
fixRange = False
End If
End If
Next
'*******************************************************************************************************
'****************** SINGLE CHART ***********************************************************************
'*******************************************************************************************************
Else
myChart.HasLegend = False
myChart.Parent.Top = 40
myChart.Parent.Left = 300
lastRow = getLastRow(ws, 1)
With myChart.SeriesCollection.NewSeries
.Values = "=" & ws.Name & "!$E$2:$E$" & lastRow
.XValues = "=" & ws.Name & "!$B$2:$B$" & lastRow
End With
' Range on axis
myChart.Axes(xlPrimary).MinimumScale = CDate(Application.WorksheetFunction.Min(Range(ws.Name & "!$B$2:$B$" & lastRow).Value2))
myChart.Axes(xlPrimary).MaximumScale = CDate(Application.WorksheetFunction.Max(Range(ws.Name & "!$B$2:$B$" & lastRow).Value2))
End If
' *********************************************************************
' ******************* Sizing ******************************************
' *********************************************************************
With myChart.PlotArea
temp = .Top
temp = .height
.Top = 70
.height = 420
End With
'really dirty and crappy formatting of title
myChart.ChartTitle.Text = "Faraday Torr"
'X axis name
myChart.Axes(xlCategory, xlPrimary).HasTitle = True
myChart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Time [s]"
'y-axis name
myChart.Axes(xlValue, xlPrimary).HasTitle = True
myChart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Pressure[Torr]"
Set myChart = Nothing
Set wsOther = Nothing
ws.Select
ws.Range("A1").Select
End Sub
I have a worksheet with 300 columns and would like to create one scatter plot for each column, bringing data from two other sheets that are in the same worksheet.
The problem is that I´m not familiar with VBA, and some error codes don't help at all.
Private Sub Create_Charts()
Dim sh As Worksheet
Dim chrt As Chart
For i = 1 To 300
Set sh = ActiveWorkbook.Worksheets("Graphs")
Set chrt = sh.Shapes.AddChart.Chart
With chrt
'Data
.ChartType = xlXYScatter
.SeriesCollection.NewSeries
.SeriesCollection(1).Name = "=""Scatter Chart"""
'With the following parameters it works:
'.SeriesCollection(1).XValues = "=OP!$c$4:$c$1588"
'.SeriesCollection(1).Values = "=PV!$c$4:$c$1588"
'But I need something like this:
.SeriesCollection(1).XValues = CStr(Worksheets("PV").Range(Cells(i, 4), Cells(i, 1588)))
.SeriesCollection(1).Values = CStr(Worksheets("OV").Range(Cells(i, 4), Cells(i, 1588)))
'Location
.ChartArea.Left = 380 * i - 380
.ChartArea.Top = 100
.ChartArea.Height = 360
.ChartArea.Width = 360
'Formatting
.Axes(xlCategory).HasMajorGridlines = True
.Axes(xlValue).HasMajorGridlines = True
.HasAxis(xlCategory, xlPrimary) = False
.HasAxis(xlValue, xlPrimary) = False
.HasLegend = False
End With
Next i
End Sub
This line references a column:
.SeriesCollection(1).XValues = "=OP!$c$4:$c$1588"
This references a row, row i from column 4 to column 1588:
.SeriesCollection(1).XValues = CStr(Worksheets("PV").Range(Cells(i, 4), Cells(i, 1588)))
But you also need to reference not only Range but Cells. And if you pass in a string address, you need the leading "="; it's easier to pass in a range. So try this:
Dim wsPV As Worksheet, wsOV As Worksheet
Dim rngX As Range, rngY As Range
Set wsPV = ActiveWorkbook.Worksheets("PV")
Set wsOV = ActiveWorkbook.Worksheets("OV")
Set rngX = wsPV.Range(wsPV.Cells(4, i), wsPV.Cells(1588, i)
Set rngY = wsOV.Range(wsOV.Cells(4, i), wsOV.Cells(1588, i)
chrt.SeriesCollection(1).XValues = rngX
chrt.SeriesCollection(1).Values = rngY
I am trying to use a sub routine to run through 10 team names in a sheet called Parameter. Each of the team names has its own sheet. I am trying to get the user to select the range and then have my sub run through and create charts for the 10 teams based on the range selected.
Sub test()
Dim rng As Range
Dim r As String
Application.ScreenUpdating = False
Dim TeamName As String
Set rng = Application.InputBox( _
Prompt:="Select a range.", _
Title:="Obtain Range Object", Type:=8)
r = "'" & TeamName & "'!" & rng.CurrentRegion.Address(ReferenceStyle:=xlR1C1)
For i = 1 To 10
TeamName = Sheets("Parameter").Range("E" & i).Value 'identify the location
Call charts(TeamName) ' Call subroutine
Next i
Application.ScreenUpdating = True
End Sub
Sub charts(TeamName As String)
Dim strTitle As Integer
Dim chtObj As ChartObject
Dim i As Integer
For Each chtObj In ActiveSheet.ChartObjects
chtObj.Delete
Next
For i = 1 To 42 Step 4
j = j + 1
Endrow = Range("A1").End(xlUp).Row - 1
Set Range1 = r.Offset(Endrow, i + 1)
Sheets(TeamName).Select
strTitle = j
MyFunction = ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlLineMarkers
ActiveChart.HasLegend = False
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = "PC " & j
ActiveChart.SetSourceData Source:=Range1
Dim MyWidth As Single, MyHeight As Single
Dim NumWide As Long
Dim iChtIx As Long, iChtCt As Long
MyWidth = 300
MyHeight = 200
NumWide = 5
iChtCt = ActiveSheet.ChartObjects.Count
For iChtIx = 1 To iChtCt
With ActiveSheet.ChartObjects(iChtIx)
.Width = MyWidth
.Height = MyHeight
.Left = ((iChtIx - 1) Mod NumWide) * MyWidth
.Top = Int((iChtIx - 1) / NumWide) * MyHeight
End With
Next
ActiveChart.SetElement (msoElementPrimaryCategoryAxisNone)
ActiveChart.SetElement (msoElementPrimaryValueGridLinesNone)
Next i
End Sub
A lot of the below code is duplicated for each cell I'm pasting to a new worksheet.
As an educational exercise, can anyone show me how I might shorten it?
Sub RowForTracker()
Worksheets.Add(After:=Worksheets(1)).Name = "ForTracker"
Sheets("Summary").Range("C2").Copy
Sheets("ForTracker").Range("A1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C6").Copy
Sheets("ForTracker").Range("B1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C8").Copy
Sheets("ForTracker").Range("C1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C3").Copy
Sheets("ForTracker").Range("D1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("H8").Copy
Sheets("ForTracker").Range("E1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("H9").Copy
Sheets("ForTracker").Range("F1").PasteSpecial Paste:=xlPasteValues
Sheets("Summary").Range("C5").Copy
Sheets("ForTracker").Range("G1").PasteSpecial Paste:=xlPasteValues
End Sub
another additional examples how you can achieve CopyPaste
Sub test1()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
With T
.[A1] = S.[C2]
.[B1] = S.[C6]
.[C1] = S.[C8]
.[D1] = S.[C3]
.[E1] = S.[H8]
.[F1] = S.[H9]
.[G1] = S.[C5]
End With
End Sub
variant using array
Sub test2()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
Dim CopyPaste, x%
x = 0
With S
CopyPaste = Array(.[C2], .[C6], .[C8], .[C3], .[H8], .[H9], .[C5])
End With
For Each oCell In T.[A1:G1]
oCell.Value = CopyPaste(x): x = x + 1
Next
End Sub
variant using split string
Sub test3()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
Dim CopyPaste$
With S
CopyPaste = .[C2] & "|" & .[C6] & "|" & .[C8] & "|" & .[C3] & "|" & .[H8] & "|" & .[H9] & "|" & .[C5]
End With
T.[A1:G1] = Split(CopyPaste, "|")
End Sub
variant using dictionary
Sub test4()
Dim S As Worksheet: Set S = Sheets("Summary")
Dim T As Worksheet: Set T = Sheets("ForTracker")
Dim CopyPaste As Object: Set CopyPaste = CreateObject("Scripting.Dictionary")
Dim oCell As Range, Key As Variant, x%
x = 1
For Each oCell In S.[C2,C6,C8,C3,H8,H9,C5]
CopyPaste.Add x, oCell.Value: x = x + 1
Next
x = 0
For Each Key In CopyPaste
T.[A1].Offset(, x).Value = CopyPaste(Key)
x = x + 1
Next
End Sub
Well, if you want to just simplify it, you can do this:
Sub Main()
Dim wsS As Worksheet
Dim wsT As Worksheet
Set wsS = Sheets("Summary")
Set wsT = Sheets("ForTracker")
wsT.Range("A1").Value = wsS.Range("C2").Value
wsT.Range("B1").Value = wsS.Range("C6").Value
wsT.Range("C1").Value = wsS.Range("C8").Value
wsT.Range("D1").Value = wsS.Range("C3").Value
wsT.Range("E1").Value = wsS.Range("H8").Value
wsT.Range("F1").Value = wsS.Range("H9").Value
wsT.Range("G1").Value = wsS.Range("C5").Value
End Sub
It may not be necessary this time, but as you said, you wished for an educational excersise, you could create a procedure just for copying cell values from one to another. It could look like this:
Sub CopyValue(CopyFrom As Range, PasteTo As Range)
PasteTo.Value = CopyFrom.Value
End Sub
And you would call it like this:
CopyValue wsS.Range("C2"), wsT.Range("A1")
Or alternativelly, if you wanted to be extra clear, like this:
CopyValue CopyFrom:=wsS.Range("C2"), PasteTo:=wsT.Range("A1")
One way
Dim target As Range, item As Range, i As Long
With Worksheets.Add(After:=Worksheets(1))
.Name = "ForTracker"
Set target = .Range("A1")
End With
For Each item In Sheets("summary").Range("C2,C6,C8,C3,H8,H9,C5")
target.Offset(0, i).value = item.value
i = i + 1
Next
Try this:
Sub RowForTracker()
Dim wksSummary As Worksheet
Dim wksForTracker As Worksheet
Worksheets.Add(After:=Worksheets(1)).Name = "ForTracker"
Set wksSummary = Sheets("Summary")
Set wksForTracker = Sheets("ForTracker")
With wksForTracker
.Range("A1").Value = wksSummary.Range("C2").Value
.Range("B1").Value = wksSummary.Range("C6").Value
.Range("C1").Value = wksSummary.Range("C8").Value
.Range("D1").Value = wksSummary.Range("C3").Value
.Range("E1").Value = wksSummary.Range("H8").Value
.Range("F1").Value = wksSummary.Range("H9").Value
.Range("G1").Value = wksSummary.Range("C5").Value
End With
End Sub