I currently have a VBA script which generates a combined chart from some data. My manager has requested that the "grand total" column (a sum of all the other columns) be present in the data table below. However, he does not want it present in the graph itself. I know that were I doing this manually, I would be able to double-click the circled column and set its Fill to "No Fill," but I cannot figure how how to do this in VBA. Note I am not trying to hide the entire series, just the circled column in the picture below.
What I have:
Picture of Incorrect Chart
What I'm trying to accomplish:
Picture of Corrected Chart
Thanks for your time!
EDIT: Plotting Code:
'Plotting!
Dim dblMax As Double
dblMax = Application.WorksheetFunction.Max(dpws.Range("B2:P4"))
Dim chrt As Chart
Set chrt = pws.Shapes.AddChart.Chart
With chrt
.ChartArea.Left = 200
.ChartArea.Top = 0
.ChartArea.Height = 500
.ChartArea.Width = 800
.Legend.Position = xlLegendPositionBottom
.ChartType = xlColumnStacked
.HasDataTable = True
.SetSourceData Source:=dpws.UsedRange
.SeriesCollection("Forecasted % Complete").AxisGroup = 2
.SeriesCollection("Forecasted % Complete").ChartType = xlLineMarkers
.SeriesCollection("Forecasted % Complete").MarkerStyle = xlMarkerStyleSquare
.SeriesCollection("Cumulative").ChartType = xlLine
.SeriesCollection("Cumulative").Format.Line.Visible = False
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = dblMax + dblMax * 0.2
.Axes(xlValue, xlSecondary).MinimumScale = 0
.Axes(xlValue, xlSecondary).MaximumScale = 1
End With
And below you will find the full code.
Sub MyCode()
Dim dws As Worksheet
Dim pws As Worksheet
Dim start As Range
Dim dataRange As Range
Dim pvtCache As PivotCache
Dim pvt As PivotTable
Dim startPvt As String
Dim lastCol As Integer
'Create ChartBin, ChartDate columns.
Set dws = Sheets("Sheet1")
With dws
lastCol = dws.Cells(1, .Columns.Count).End(xlToLeft).Column
.Cells(1, lastCol + 1).Value = "Chart_Bin"
.Cells(1, lastCol + 2).Value = "Chart_Date_Group"
End With
'Populate Chart Columns
Dim i As Long
Dim thisMonth As Integer
Dim hwswDateCol As Long
Dim statusCol As Long
Dim hwswDateGrpCol As Long
hwswDateCol = 162
statusCol = 13
hwswDateGrpCol = 163 'Really should search for these column titles.
thisMonth = Month(Date)
With dws
For i = 2 To .UsedRange.Rows.Count Step 1
.Cells(i, lastCol + 2).Value = .Cells(i, hwswDateGrpCol).Value
'If complete...
If (.Cells(i, statusCol) = "Complete") Then
.Cells(i, lastCol + 1).Value = "Complete"
'If not complete, date passed...
ElseIf (thisMonth - Month(.Cells(i, hwswDateCol)) > 0) Then
.Cells(i, lastCol + 1).Value = "Missed"
Else
.Cells(i, lastCol + 1).Value = "Forecasted"
End If
Next i
End With
'Copy just data we need to reduce pivot size.
Set rws = Sheets.Add
rws.Name = "Raw"
dws.Columns(1).Copy Destination:=rws.Columns(1)
dws.Columns(2).Copy Destination:=rws.Columns(2)
dws.Columns(4).Copy Destination:=rws.Columns(3)
dws.Columns(8).Copy Destination:=rws.Columns(4)
dws.Columns(10).Copy Destination:=rws.Columns(5)
dws.Columns(22).Copy Destination:=rws.Columns(6)
dws.Columns(131).Copy Destination:=rws.Columns(7)
dws.Columns(11).Copy Destination:=rws.Columns(8)
dws.Columns(101).Copy Destination:=rws.Columns(9)
dws.Columns(lastCol + 1).Copy Destination:=rws.Columns(10)
dws.Columns(lastCol + 2).Copy Destination:=rws.Columns(11)
'Create pivots.
Set pws = Sheets.Add
pws.Name = "Pivot"
Set start = rws.Range("A1")
Set dataRange = rws.Range(start, start.SpecialCells(xlLastCell))
startPvt = pws.Name & "!" & pws.Range("T1").Address(ReferenceStyle:=x1R1C1)
Set pvtCache = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=dataRange)
Set pvt = pvtCache.CreatePivotTable(TableDestination:=startPvt, TableName:="Market Totals")
pvt.PivotFields("Chart_Date_Group").Orientation = xlColumnField
pvt.PivotFields("Chart_Bin").Orientation = xlRowField
pvt.PivotFields("JOB NUMBER").Orientation = xlDataField
'Add slicers.
Dim sl As Slicer
Dim sls As Slicers
Dim slcs As SlicerCaches
Dim slc As SlicerCache
Set slcs = ActiveWorkbook.SlicerCaches
Set sls = slcs.Add(pws.PivotTables(1), "Carrier Type", "Carrier_Type").Slicers
Set sl = sls.Add(pws, , "Carrier_Type", "Carrier Type", 0, 0, 200, 75)
Set sls = slcs.Add(pws.PivotTables(1), "AVP", "AVP").Slicers
Set sl = sls.Add(pws, , "AVP", "AVP Type", 75, 0, 100, 250)
Set sls = slcs.Add(pws.PivotTables(1), "MARKET_RPA", "MARKET_RPA").Slicers
Set sl = sls.Add(pws, , "MARKET_RPA", "MARKET_RPA", 75, 100, 100, 400)
Set sls = slcs.Add(pws.PivotTables(1), "Driver", "Driver").Slicers
Set sl = sls.Add(pws, , "Driver", "Driver", 325, 0, 100, 150)
Set sls = slcs.Add(pws.PivotTables(1), "VENDOR", "VENDOR").Slicers
Set sl = sls.Add(pws, , "VENDOR", "VENDOR", 475, 0, 100, 150)
Set sls = slcs.Add(pws.PivotTables(1), "Hardware Location", "Hardware_Location").Slicers
Set sl = sls.Add(pws, , "Hardware_Location", "Hardware Location", 475, 100, 100, 200)
Set sls = slcs.Add(pws.PivotTables(1), "IWOS Flag", "IWOS_Flag").Slicers
Set sl = sls.Add(pws, , "IWOS_Flag", "IWOS Flag", 675, 0, 200, 125)
'Add data to data prep worksheet.
Dim dpws As Worksheet
Set dpws = Sheets.Add
dpws.Name = "Data Prep"
dpws.Cells(2, 1).Value = "Complete"
dpws.Cells(3, 1).Value = "Forecasted"
dpws.Cells(4, 1).Value = "Missed"
dpws.Cells(5, 1).Value = "Cumulative"
dpws.Cells(6, 1).Value = "Forecasted % Complete"
dpws.Cells(1, 2).Value = "2015"
dpws.Cells(1, 3).Value = "2016 Jan"
dpws.Cells(1, 4).Value = "2016 Feb"
dpws.Cells(1, 5).Value = "2016 Mar"
dpws.Cells(1, 6).Value = "2016 Apr"
dpws.Cells(1, 7).Value = "2016 May"
dpws.Cells(1, 8).Value = "2016 Jun"
dpws.Cells(1, 9).Value = "2016 Jul"
dpws.Cells(1, 10).Value = "2016 Aug"
dpws.Cells(1, 11).Value = "2016 Sep"
dpws.Cells(1, 12).Value = "2016 Oct"
dpws.Cells(1, 13).Value = "2016 Nov"
dpws.Cells(1, 14).Value = "2016 Dec"
dpws.Cells(1, 15).Value = "2017"
dpws.Cells(1, 16).Value = "2018"
For i = 2 To dpws.UsedRange.Columns.Count Step 1
dpws.Cells(2, i).Value = WorksheetFunction.IfError(pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Complete", "Chart_Date_Group", dpws.Cells(1, i).Value), 0)
dpws.Cells(3, i).Value = WorksheetFunction.IfError(pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Forecasted", "Chart_Date_Group", dpws.Cells(1, i).Value), 0)
dpws.Cells(4, i).Value = WorksheetFunction.IfError(pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Missed", "Chart_Date_Group", dpws.Cells(1, i).Value), 0)
Next i
dpws.Cells(1, 17).Value = "Grand Total"
dpws.Cells(2, i) = pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Complete")
dpws.Cells(3, i) = pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Forecasted")
dpws.Cells(4, i) = pvt.GetPivotData("JOB NUMBER", "Chart_Bin", "Missed")
dpws.Cells(5, i) = pvt.GetPivotData("JOB NUMBER")
'Calculate percentages/cumulatives.
Dim grandTotalCol As Integer
Dim percentageRow As Integer
Dim sumRow As Integer
Dim prevValue As Double
prevValue = 0
grandTotalCol = i
sumRow = 5
percentageRow = 6
With dpws
For i = 2 To dpws.UsedRange.Columns.Count Step 1
.Cells(sumRow, i).Value = WorksheetFunction.Sum(.Range(.Cells(2, i), .Cells(4, i))) + prevValue
prevValue = .Cells(sumRow, i).Value
If i = dpws.UsedRange.Columns.Count - 1 Then
prevValue = 0
End If
.Cells(percentageRow, i).Value = dpws.Cells(sumRow, i).Value / dpws.Cells(5, grandTotalCol).Value
.Cells(percentageRow, i).NumberFormat = "0%"
Next i
End With
'Plotting!
Dim dblMax As Double
dblMax = Application.WorksheetFunction.Max(dpws.Range("B2:P4"))
Dim chrt As Chart
Set chrt = pws.Shapes.AddChart.Chart
With chrt
.ChartArea.Left = 200
.ChartArea.Top = 0
.ChartArea.Height = 500
.ChartArea.Width = 800
.Legend.Position = xlLegendPositionBottom
.ChartType = xlColumnStacked
.HasDataTable = True
.SetSourceData Source:=dpws.UsedRange
.SeriesCollection("Forecasted % Complete").AxisGroup = 2
.SeriesCollection("Forecasted % Complete").ChartType = xlLineMarkers
.SeriesCollection("Forecasted % Complete").MarkerStyle = xlMarkerStyleSquare
.SeriesCollection("Cumulative").ChartType = xlLine
.SeriesCollection("Cumulative").Format.Line.Visible = False
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = dblMax + dblMax * 0.2
.Axes(xlValue, xlSecondary).MinimumScale = 0
.Axes(xlValue, xlSecondary).MaximumScale = 1
End With
End Sub
Just added 2 lines of code to your original 'Plotting Section
Dim dblMax As Double
dblMax = Application.WorksheetFunction.Max(dpws.Range("B2:P4"))
Dim chrt As Chart
Set chrt = pws.Shapes.AddChart.Chart
With chrt
.ChartArea.Left = 200
.ChartArea.Top = 0
.ChartArea.Height = 500
.ChartArea.Width = 800
.Legend.Position = xlLegendPositionBottom
.ChartType = xlColumnStacked
.HasDataTable = True
.SetSourceData Source:=dpws.UsedRange
.SeriesCollection("Forecasted % Complete").AxisGroup = 2
.SeriesCollection("Forecasted % Complete").ChartType = xlLineMarkers
.SeriesCollection("Forecasted % Complete").MarkerStyle = xlMarkerStyleSquare
.SeriesCollection("Cumulative").ChartType = xlLine
' Added the 2 lines below
.SeriesCollection("Cumulative").Format.Fill.Visible = msoFalse
.SeriesCollection("Cumulative").Format.Line.Visible = msoFalse
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = dblMax + dblMax * 0.2
.Axes(xlValue, xlSecondary).MinimumScale = 0
.Axes(xlValue, xlSecondary).MaximumScale = 1
nd With
Related
My program appears in the VBA screen to be working, but on the Excel doc it's manipulating, not so much.
It is supposed to loop down a root column, populating off of it to other sheets, until the root column comes to a blank cell. When I run the loop, it does loop, and the plus 1 shows that it took effect for RW variable, when I hover over it in the VBA stepo through process. Yet it just keeps entering values from the same row over and over again as if RW isn't advancing when I can see that it is, and it keeps copying to the same row, when again, I can see the RW variable advancing by 1 in the VBA editor.
Here's the code.
Sub ExportData()
Dim RW As Integer
RW = 2
Dim CL As Integer
CL = 3
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "US"
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "CA"
End With
Dim SKUUS As Range
Set SKUUS = Sheets("US").Cells(RW - 1, CL - 2)
Dim SKUCA As Range
Set SKUCA = Sheets("CA").Cells(RW - 1, CL - 2)
Dim RootSKU As Variant
Set RootSKU = Sheets("tblTEMP").Cells(RW, CL)
AvailDate = InputBox("What is Available Date?")
PromoCode = InputBox("What is the Promo Code?")
'HeadersUS
SKUUS.Value = "Item #"
SKUUS.Offset(0, 1).Value = "MAX QTY"
SKUUS.Offset(0, 2).Value = "PROMO Price"
SKUUS.Offset(0, 3).Value = "AvailableDate"
SKUUS.Offset(0, 4).Value = "VendorNumOverride"
SKUUS.Offset(0, 5).Value = "PromoListPrice"
SKUUS.Offset(0, 6).Value = "BOGO ITEM #"
SKUUS.Offset(0, 7).Value = "BOGO QTY"
SKUUS.Offset(0, 8).Value = "ProgramCode"
SKUUS.Offset(0, 9).Value = "PromoCode"
'HeadersCA
SKUCA.Value = "Item #"
SKUCA.Offset(0, 1).Value = "MAX QTY"
SKUCA.Offset(0, 2).Value = "PROMO Price"
SKUCA.Offset(0, 3).Value = "AvailableDate"
SKUCA.Offset(0, 4).Value = "VendorNumOverride"
SKUCA.Offset(0, 5).Value = "PromoListPrice"
SKUCA.Offset(0, 6).Value = "BOGO ITEM #"
SKUCA.Offset(0, 7).Value = "BOGO QTY"
SKUCA.Offset(0, 8).Value = "ProgramCode"
SKUCA.Offset(0, 9).Value = "PromoCode"
Do
'Populate First Row in US
SKUUS.Offset(1, 0) = RootSKU.Value
SKUUS.Offset(1, 1) = RootSKU.Offset(0, 12).Value * 0.8
SKUUS.Offset(1, 1) = Math.Round(SKUUS.Offset(1, 1).Value, 0)
SKUUS.Offset(1, 2) = RootSKU.Offset(0, 7).Value
SKUUS.Offset(1, 3) = AvailDate
SKUUS.Offset(1, 5) = RootSKU.Offset(0, 6).Value
SKUUS.Offset(1, 9) = PromoCode
'Populate First Row in US
SKUCA.Offset(1, 0) = RootSKU.Value
SKUCA.Offset(1, 1) = RootSKU.Offset(0, 12).Value * 0.2
SKUCA.Offset(1, 1) = Math.Round(SKUCA.Offset(1, 1).Value, 0)
SKUCA.Offset(1, 2) = RootSKU.Offset(0, 10).Value
SKUCA.Offset(1, 3) = AvailDate
SKUCA.Offset(1, 5) = RootSKU.Offset(0, 9).Value
SKUCA.Offset(1, 9) = PromoCode
RW = RW + 1
Loop Until RootSKU = ""
End Sub
I moved the variable to inside the loop, but still get the same result. After playing around with it a bit on the premise, I was able to get it to work like this. Thanks for the assist.
Sub ExportData()
Dim RW As Long
Dim CL As Long
Dim SKUUS As Range
Dim SKUCA As Range
Dim RootSKU As Variant
RW = 2
CL = 1
With ThisWorkbook
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "US"
.Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "CA"
End With
AvailDate = InputBox("What is Available Date?")
PromoCode = InputBox("What is the Promo Code?")
'HeadersUS
Sheets("US").Range("A1") = "Item #"
Sheets("US").Range("B1") = "MAX QTY"
Sheets("US").Range("C1") = "PROMO Price"
Sheets("US").Range("D1") = "AvailableDate"
Sheets("US").Range("E1") = "VendorNumOverride"
Sheets("US").Range("F1") = "PromoListPrice"
Sheets("US").Range("G1") = "BOGO ITEM #"
Sheets("US").Range("H1") = "BOGO QTY"
Sheets("US").Range("I1") = "ProgramCode"
Sheets("US").Range("J1") = "PromoCode"
'HeadersCA
Sheets("CA").Range("A1") = "Item #"
Sheets("CA").Range("B1") = "MAX QTY"
Sheets("CA").Range("C1") = "PROMO Price"
Sheets("CA").Range("D1") = "AvailableDate"
Sheets("CA").Range("E1") = "VendorNumOverride"
Sheets("CA").Range("F1") = "PromoListPrice"
Sheets("CA").Range("G1") = "BOGO ITEM #"
Sheets("CA").Range("H1") = "BOGO QTY"
Sheets("CA").Range("I1") = "ProgramCode"
Sheets("CA").Range("J1") = "PromoCode"
Do
Set SKUUS = Sheets("US").Cells(RW, CL)
Set SKUCA = Sheets("CA").Cells(RW, CL)
Set RootSKU = Sheets("tblTEMP").Cells(RW, CL + 2)
'Populate First Row in US
SKUUS = RootSKU.Value
SKUUS.Offset(0, 1) = RootSKU.Offset(0, 12).Value * 0.8
SKUUS.Offset(0, 1) = Math.Round(SKUUS.Offset(0, 1).Value, 0)
SKUUS.Offset(0, 2) = RootSKU.Offset(0, 7).Value
SKUUS.Offset(0, 3) = AvailDate
SKUUS.Offset(0, 5) = RootSKU.Offset(0, 6).Value
SKUUS.Offset(0, 9) = PromoCode
'Populate First Row in US
SKUCA = RootSKU.Value
SKUCA.Offset(0, 1) = RootSKU.Offset(0, 12).Value * 0.2
SKUCA.Offset(0, 1) = Math.Round(SKUCA.Offset(0, 1).Value, 0)
SKUCA.Offset(0, 2) = RootSKU.Offset(0, 10).Value
SKUCA.Offset(0, 3) = AvailDate
SKUCA.Offset(0, 5) = RootSKU.Offset(0, 9).Value
SKUCA.Offset(0, 9) = PromoCode
RW = RW + 1
Loop Until RootSKU.Offset(1, 0) = ""
End Sub
I have this code that transfers data to a sheet and creates a data base of : Name, DOB, Phone number, Insurance name, Insurance ID.
Dim strDataRange As Range
Dim keyRange As Range
Set strDataRange = Range("A1:h5000")
Set keyRange = Range("A1:h5000")
strDataRange.Sort Key1:=keyRange, Header:=xlYes
Dim tr As Worksheet
Set tr = Worksheets("Sheet16")
iRow = tr.Cells(Rows.Count, 1) _
.End(xlUp).Offset(1, 0).Row
tr.Cells(iRow, 1).Value = Me.TextBox1.Value
tr.Cells(iRow, 2).Value = Me.TextBox2.Value
tr.Cells(iRow, 3).Value = Me.TextBox22.Value
tr.Cells(iRow, 4).Value = Me.TextBox23.Value
tr.Cells(iRow, 5).Value = Me.TextBox17.Value
tr.Cells(iRow, 6).Value = Me.ComboBox15.Value
tr.Cells(iRow, 7).Value = Me.TextBox21.Value
tr.Cells(iRow, 8).Value = Me.TextBox32.Value
Then on this code, I am able to call all that information enter before (above code) and its populates on textboxes:
Private Sub ComboBox13_Change()
On Error Resume Next
Me.TextBox1.Value = Me.ComboBox13.Column(0)
Me.TextBox2.Value = Me.ComboBox13.Column(1)
Me.TextBox22.Value = Me.ComboBox13.Column(2)
Me.TextBox23.Value = Me.ComboBox13.Column(3)
Me.TextBox17.Value = Me.ComboBox13.Column(4)
Me.ComboBox15.Value = Me.ComboBox13.Column(5)
Me.TextBox21.Value = Me.ComboBox13.Column(6)
Me.TextBox32.Value = Me.ComboBox13.Column(7)
On Error GoTo 0
End Sub
With ComboBox13
.ColumnCount = 1
.ColumnWidths = "120"
.ColumnHeads = False
.RowSource = "Sheet16!A2:h5200"
End With
What I can't do or I need to do is, If the data change on any of these
enter code heretext boxes and I need to update the information such as
: phone 'number or Insurance Id. How can I change it on those text boxes
and press a 'command button to update that new data enter?
Thanks a lot
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 want to add many option button to an excel worksheet (not to a VBA-form) and want to group them by row. The result should look something like this:
Here is the code I'm using so far:
For d = 1 To 31
Set checkboxKrankCell = Range("H" + Trim(Str(d)))
Set checkboxUrlaubCell = Range("I" + Trim(Str(d)))
Set checkboxJazCell = Range("J" + Trim(Str(d)))
groupWidth = checkboxKrankCell.Width + checkboxUrlaubCell.Width + checkboxJazCell.Width
Set groupBoxOptionButtons = ActiveSheet.GroupBoxes.Add(checkboxKrankCell.Left - 1, checkboxKrankCell.Top - 2, groupWidth + 1, checkboxKrankCell.Height)
With groupBoxOptionButtons
.Name = "GroupBox_" + Trim(Str(d))
.Caption = ""
End With
Set checkboxKrank = ActiveSheet.OptionButtons.Add(checkboxKrankCell.Left, checkboxKrankCell.Top - 1, checkboxKrankCell.Width, checkboxKrankCell.Height)
With checkboxKrank
.Caption = ""
End With
#1 checkboxKrank.GroupBox = groupBoxOptionButtons
Set checkboxUrlaub = ActiveSheet.OptionButtons.Add(checkboxUrlaubCell.Left, checkboxUrlaubCell.Top - 1, checkboxUrlaubCell.Width, checkboxUrlaubCell.Height)
With checkboxUrlaub
.Caption = ""
End With
Set checkboxJaz = ActiveSheet.OptionButtons.Add(checkboxJazCell.Left, checkboxJazCell.Top - 1, checkboxJazCell.Width, checkboxJazCell.Height)
With checkboxJaz
.Caption = ""
#2 .GroupBox = groupBoxOptionButtons
End With
Next d
I would expect to assign the option buttons to the group for the current row by setting the GroupBox property (see #1 or #2).
But both methods just gave me an error saying 'The object does not support the property or methode'.
Any help or hint is welcome ;-)
Based on the tip from snb I have modified my function like this:
Sub AddOptionButtons()
ActiveSheet.OptionButtons.Delete
For d = 1 To 31
Set checkboxKrankCell = Range("H" + Trim(Str(d + 4)))
Set checkboxUrlaubCell = Range("I" + Trim(Str(d + 4)))
Set checkboxJazCell = Range("J" + Trim(Str(d + 4)))
option1Name = "Krank_" + Trim(Str(d))
option2Name = "Urlaub_" + Trim(Str(d))
option3Name = "Jaz_" + Trim(Str(d))
Set checkboxKrank = ActiveSheet.OptionButtons.Add(checkboxKrankCell.Left, checkboxKrankCell.Top - 1, checkboxKrankCell.Width, checkboxKrankCell.Height)
With checkboxKrank
.Caption = ""
.Name = option1Name
End With
Set checkboxUrlaub = ActiveSheet.OptionButtons.Add(checkboxUrlaubCell.Left, checkboxUrlaubCell.Top - 1, checkboxUrlaubCell.Width, checkboxUrlaubCell.Height)
With checkboxUrlaub
.Caption = ""
.Name = option2Name
End With
Set checkboxJaz = ActiveSheet.OptionButtons.Add(checkboxJazCell.Left, checkboxJazCell.Top - 1, checkboxJazCell.Width, checkboxJazCell.Height)
With checkboxJaz
.Caption = ""
.Name = option3Name
End With
ActiveSheet.Shapes.Range(Array(option1Name, option2Name, option3Name)).Group
Next d
End Sub
I don't get any errors using Shapes.Range(...).Group.
But still all option buttons from on the sheet are all mutual exclusive.
Seems grouping does not work here.
Try the following code on an empty workbook. It will give you an option to choose only ONE optionbutton on each row, which is what you want, as far as I understood (I also created a linked cell reference, just in case you would like to take further action, given the choice of a user.):
Sub AddOptionButtons()
Dim btn1 As OptionButton
Dim btn2 As OptionButton
Dim btn3 As OptionButton
Dim grbox As GroupBox
Dim t As Range
Dim s As Range
Dim p As Range
Dim i As Integer
ActiveSheet.OptionButtons.Delete
ActiveSheet.GroupBoxes.Delete
For i = 5 To 35 Step 1
Set t = ActiveSheet.Range(Cells(i, 8), Cells(i, 8))
Set s = ActiveSheet.Range(Cells(i, 9), Cells(i, 9))
Set p = ActiveSheet.Range(Cells(i, 10), Cells(i, 10))
Set btn1 = ActiveSheet.OptionButtons.Add(t.Left, t.Top, t.Width, t.Height)
Set btn2 = ActiveSheet.OptionButtons.Add(s.Left, s.Top, s.Width, s.Height)
Set btn3 = ActiveSheet.OptionButtons.Add(p.Left, p.Top, p.Width, p.Height)
Set grbox = ActiveSheet.GroupBoxes.Add(t.Left, t.Top, t.Width + 100, t.Height)
With btn1
.Caption = ""
.Display3DShading = True
.LinkedCell = "M" & i
End With
With btn2
.Caption = ""
.Display3DShading = True
End With
With btn3
.Caption = ""
.Display3DShading = True
End With
With grbox
.Caption = ""
.Visible = False
End With
Next i
End Sub
I'd use:
Sub M_snb()
ReDim sn(2)
For j = 1 To 2
For jj = 1 To 3
With Sheet1.OptionButtons.Add(Cells(j, jj).Left, Cells(j, jj).Top - 1, Cells(j, jj).Width, Cells(j, jj).Height)
sn(jj - 1) = .Name
End With
Next
Sheet1.Shapes.Range(sn).Group
Next
End Sub
I wrote the following code to add a chart and position it on a worksheet with data on it:
Dim sh As Worksheet
Dim chrteit As Chart
lastrows = Range("A2").End(xlDown).Row
Set sh = ActiveWorkbook.Worksheets("TraceTable")
Set chrteit = sh.Shapes.AddChart.Chart
With chrteit
.ChartType = xlXYScatter
.SeriesCollection.NewSeries
.SeriesCollection(1).XValues = sh.Range(Cells(2, 6), Cells(lastrows, 6))
.SeriesCollection(1).Values = sh.Range(Cells(2, 7), Cells(lastrows, 7))
.HasTitle = True
.ChartTitle.Text = "EIT"
.Parent.Height = Range("N2:N14").Height
.Parent.Width = Range("N2:T2").Width
.Parent.top = Range("N2").top
.Parent.Left = Range("N2").Left
End With
The problem is, later in my module I have a macro that will an entire row between two data points if the two data points are different, and it is as follows:
Private Sub Dividers()
Dim DividerRange As Range, lastrow As Long, k As Integer, counter As Integer
lastrow = Range("C2").End(xlDown).Row
Set DividerRange = Range(Cells(2, 3), Cells(lastrow, 3))
counter = 0
For k = 2 To DividerRange.Count
If DividerRange(k + counter).Value <> DividerRange(k + counter - 1).Value Then
DividerRange(k + counter).EntireRow.Insert
counter = counter + 1
Else
End If
Next k
End Sub
By adding the entire row, it changes the height of my graph and it's position. I want it to be a fixed position, how can I do this? I would PREFER not to change the second code, but rather the first but let me know any solutions you guys have, Thanks!
Add this line to the first procedure:
chrteit.Placement = xlFreeFloating
This is the same as right-click, format chart area, properties: Don't move or size with cells.
|
Or you could place that method inside the With block, thusly:
With chrteit
.ChartType = xlXYScatter
.SeriesCollection.NewSeries
.SeriesCollection(1).XValues = sh.Range(Cells(2, 6), Cells(lastrows, 6))
.SeriesCollection(1).Values = sh.Range(Cells(2, 7), Cells(lastrows, 7))
.HasTitle = True
.ChartTitle.Text = "EIT"
.Parent.Height = Range("N2:N14").Height
.Parent.Width = Range("N2:T2").Width
.Parent.top = Range("N2").top
.Parent.Left = Range("N2").Left
.Placement = xlFreeFloating
End With