I wanted to use this code
Sub PieMarkers()
Dim chtMarker As Chart
Dim chtMain As Chart
Dim intPoint As Integer
Dim rngRow As Range
Dim lngPointIndex As Long
Dim x As Long
Dim myTheme As String
Application.ScreenUpdating = False
Set chtMarker = ActiveSheet.ChartObjects("chtMarker").Chart
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart
Set rngRow = Range(ThisWorkbook.Names("PieChartValues").RefersTo)
For Each rngRow In Range("PieChartValues").Rows
chtMarker.SeriesCollection(1).Values = rngRow
SetColorScheme chtMarker, x
chtMarker.Parent.CopyPicture xlScreen, xlPicture
lngPointIndex = lngPointIndex + 1
chtMain.SeriesCollection(1).Points(lngPointIndex).Paste
x=x+1
Debug.Print rngColors.address()
Next
lngPointIndex = 0
Application.ScreenUpdating = True
End Sub
Sub SetColorScheme(cht As Chart, i As Long)
Dim y_off As Long, rngColors As Range
Dim x As Long
y_off = i Mod 13
'this is the range of cells which has the colors you want to apply
Set rngColors = ThisWorkbook.Sheets("Basic").Range(ThisWorkbook.Sheets("Basic").Range("A19").Value).Offset(y_off, 0)
With cht.SeriesCollection(1)
'loop though the points and apply the corresponding fill color from the cell
For x = 1 To .Points.Count
.Points(x).Format.Fill.ForeColor.RGB = _
rngColors.Cells(x).Interior.Color
Next x
End With
End Sub
to colour several pie charts with all of them having the same amount of slices (3 each, 8 pie charts) according to specified colours in the workbook (colours used as background colour for a cell in a worksheet).This is the Sub Colour Scheme.
The code compiles without error the problem is just that it only uses the first to specified colours in a range (say A10:Z10, only the colours in A10 and B10 to colour all pieces of the 8 pie charts (24 sclices in total with the two colours from A10 and B10). Could somebody tell me what I would need to change so that the whole colour range from A10 to X10 is used (24 different colours) for the different slices?
It seems the For loop that use cht.SeriesCollection(1).Points.Count as a boundary doesn't take you beyond two iterations.
You should rather use an inner loop specific to the range of cells you want to retrieve the color from and a if condition statement if there are less colors.
Related
I am trying to copy my chart from one sheet to another.
In my sheets I have my charts in different sizes. But in sheet2, I would like to have my charts in the same height and width.
Can anyone suggest how I can do it?
I have the below code running, just to copy the charts. I would like to have them in regular size.
Sub Overview()
Sheets("Cat").Select
ActiveSheet.ChartObjects(1).Activate
ActiveChart.ChartArea.Copy
Sheets("Overview").Select
Range("B5").Select
ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
DisplayAsIcon:=False
Range("B5").Select
If i understand you right, you want to resize all your chats in the sheet, so that they will have all the same width and height.
The Code below will run trhough all charts i a sheet and will set new Values for the width and height and will change the Position aswell.
'Set Position off all Charts
Dim intTop As Integer
Dim intLeft As Integer
Dim idx As Integer
intTop = 275 'start Position from the Top for the first chart
intLeft = 15 'strat positon from the left for the first chart
idx = 0
wsDia.Select
For Each myChart In ActiveSheet.ChartObjects
myChart.Width = 450
myChart.Height = 200
myChart.Top = intTop
myChart.Left = intLeft
intLeft = intLeft + 465
idx = idx + 1
If idx = 4 Then 'after 4 Charts, go to next row of charts
intLeft = 15
intTop = intTop + 230
idx = 0
End If
Next myChart
Update:
If you want to change the height of a PNG Picture you need to loop like this:
The first Loop is if you want the to set the Size with a locked Ratio. That means if you set the Height to 500 the Width will set automaticly.
For Each mypNg In ActiveSheet.Shapes
mypNg.Height = 500
Next
If you want the Ratio unlocket you have to add:
mypNg.LockAspectRatio = msoFalse
Try this code.
Dim Cht As Chart
Dim Ws As Worksheet, toWs As Worksheet
Set Ws = Sheets("Cat")
Set toWs = Sheets("Overview")
Set Cht = Ws.ChartObjects(1).Chart
Cht.CopyPicture
toWs.Activate
Range("b5").Activate
toWs.Paste
I have a worksheet with a matrix, which is divided diagonally with a cell that is black. The matrix contains the same header, both vertically and horisontally.
The idea is that you show the relation between the items in the bottom area, below the diagonal.
I want to create a Range (MatrixRange) that is the bottom part of the area.
What I'm trying to do is create a range for each column that I use, and add it to the MatrixRange. The different ranges im trying to combine is therefore of different height.
Dim MatrixRange As Range
Private Sub Workbook_Open()
Dim n As Integer
Dim NextRange As Range
Dim OldRange As Range
Dim ws As Worksheet
Set ws = Sheets("Systemmatrise")
With ws
For n = 1 To 68
Set OldRange = MatrixRange
Set NextRange = .Range(Range("B9").Offset(n + 1, n), Cells(78, n + 2))
Set MatrixRange = Union(OldRange, NextRange)
Next n
End With
Debug.Print MatrixRange
End Sub
I get a "Runtime error 5" after
Set MatrixRange = Union(OldRange, NextRange)
Is there an easier way to create this Range, or somehow to fix this problem?
Thanks in advance
You don't seem to set an initial range for OldRange, so it'll be Nothing during the first iteration - the likely cause of your error.
Delete this line:
Set OldRange = MatrixRange
Correct this line to include a dot in front of Cells:
Set NextRange = .Range(Range("B9").Offset(n + 1, n), .Cells(78, n + 2))
and before the For Loop, add this (extra dot noted, thanks Jeeped):
Set OldRange = .Range(.Range("B9").Offset(1,0), .Cells(78, 2))
I am working on a macro to set chart max and mins based on a dynamic data set. When the user chooses their group, the chart updates, and the macro runs to update the chart max and min values to an appropriate scale.
I am hoping someone can help me as I try to use variables from 3 ranges to:
Choose chart based on cell value in range
Set min based on cell value in range
Set max based on cell value in range
At this point I am able to pull out the chart name, but am having trouble getting the value for min and max from the range.
Any help would be appreciated!
Sub rescale()
ActiveSheet.Calculate
Dim ChrtNmRng As Range
Dim ChrtMinRng As Range
Dim ChrtMaxRng As Range
Dim cell As Range
Set ChrtNmRng = Sheets("Data").Range("o5:o20")
Set ChrtMinRng = Sheets("Data").Range("z5:z20")
Set ChrtMaxRng = Sheets("Data").Range("Aa5:Aa20")
For Each cell In ChrtNmRng
With Sheets("Dashboard").ChartObjects(cell.Value).Chart.Axes(xlValue)
.MinimumScale = ChrtMinRng.Value
.MaximumScale = ChrtMaxRng.Value
End With
Next cell
End Sub
Do it like this:
Sub rescale()
Dim ChrtNmRng As Range, cell As Range
ActiveSheet.Calculate
Set ChrtNmRng = Sheets("Data").Range("o5:o20")
For Each cell In ChrtNmRng
With Sheets("Dashboard").ChartObjects(cell.Value).Chart.Axes(xlValue)
.MinimumScale = Range("Z" & cell.Row)
.MaximumScale = Range("AA" & cell.Row)
End With
Next cell
End Sub
The key here is that your ranges for the minimum and maximum values (Z and AA) line up precisely with column O so you can use the row reference to get the corresponding values you need.
As I understand your comments. Column O contains the name of the charts and the others contain what is wanted as the min and max for each of those charts.
Sub rescale()
ActiveSheet.Calculate
Dim ChrtNmRng As Range
Dim ChrtMinRng As Range
Dim ChrtMaxRng As Range
Dim i As Long
Set ChrtNmRng = Sheets("Data").Range("o5:o20")
Set ChrtMinRng = Sheets("Data").Range("z5:z20")
Set ChrtMaxRng = Sheets("Data").Range("Aa5:Aa20")
For i = 1 To 16
With Sheets("Dashboard").ChartObjects(ChrtNmRng(i).Value).Chart.Axes(xlValue)
.MinimumScale = ChrtMinRng(i).Value
.MaximumScale = ChrtMaxRng(i).Value
End With
Next i
End Sub
I'm trying to write a macro to change the colors of rows when the values in column B change. Column A will be my controlling column using 1's and 0's, i.e. column A will stay a 1 as long as column B stays the same; whenever B changes, A will flip to a 0, and so on.
I can get it to color the rows correctly when the values in column B change, but the problem arises when I filter the data. For example: let's say I have B2-B4 set to "test1", B5-B7 set to "test2", and B8-B10 set to "test3", then I filter column B to not include "test2". Originally, the rows would be colored differently where the column values changed, but rows B2-B4 and B8-B10 are set to the same color and now they're touching since the "test2" rows are hidden.
Here's the code I used to color the rows, but it doesn't work for filtering:
Sub ColorRows()
Dim This As Long
Dim Previous As Long
Dim LastRow As Long
Dim Color As Integer
Dim R As Long
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
RwColor = Array(15,0)
Color = 0
For R = 2 To LastRow
This = Cells(R, 1).Value
Previous = Cells(R - 1, 1).Value
If This <> Previous Then Color = 1 - Color
Range("A" & R & ":M" & R).Select
Selection.Interior.ColorIndex = RwColor(Color)
Next R
End Sub
How can I fix it so that even after filtering the rows are colored correctly when there is a change in column values?
Here's a way to do this:
1.) Insert the code below as a UDF in a code module.
2.) Then put the formula in A, as A2: =analyseVisible(B2).
This will compare B-cells to the next visible cell above and result in a 'rank'-counter in A.
Now that the counter in A in contiunous (even if rows are hidden), you can use MOD 2 to color it with conditional formatting:
3.) Add a conditional format (from A2 for the whole table): =MOD($A2,2)=1 and set the fill color.
If you use the filter now or change values in B, the rows are re-colored in realtime.
Public Function analyseVisible(r As Range) As Integer
Dim i As Long
If Application.Caller.Row <= 2 Or _
r.Row <> Application.Caller.Row Then
analyseVisible = 1
Exit Function
End If
i = r.Row - 1
While r.Worksheet.Rows(i).Hidden And i > 1
i = i - 1
Wend
If i = 1 Then
analyseVisible = 1
Else
analyseVisible = r.Worksheet.Cells(i, Application.Caller.Column).Value
If r.Worksheet.Cells(i, r.Column).Value <> _
r.Value Then analyseVisible = analyseVisible + 1
End If
End Function
The code below handles the issue by checking only the used & visible rows. It works pretty well, but I was unable to figure out how to fire it when the filter changes. It also does it's comparisons directly on the values that are changing.
Private Sub colorRows()
Dim this As Variant
Dim previous As Variant
Dim currentColor As Long
Dim rng As Range 'visible range
Dim c As Range ' cell
' pick a color to start with
currentColor = vbYellow
' rng = used and visible cells
Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
For Each c In rng ' For each cell that is visible and used
If Not c.Row = 1 Then ' skip header row
this = c.Value
'some simple test logic to switch colors
If this <> previous Then
If currentColor = vbBlue Then
currentColor = vbYellow
ElseIf currentColor = vbYellow Then
currentColor = vbBlue
End If
End If
'set interior color
c.Interior.color = currentColor
previous = this
End If
Next c
End Sub
Then, in the module of the worksheet that you want to colorize, call the sub from the Worksheet_Activate() event. (In reality, you probably want a different event. I mostly work with Access, so I don't really know what's available to you. I'm just trying to point you in the right direction to what I'm sure is your next question if you stick with the method you started with.)
Private Sub Worksheet_Activate()
colorRows
End Sub
in the following code
Sub SetColorScheme(cht As Chart, i As Long)
Dim y_off As Long, rngColors As Range
Dim x As Long
y_off = i Mod 10
'this is the range of cells which has the colors you want to apply
Set rngColors = ThisWorkbook.Sheets("colors").Range("A1:C1").Offset(y_off, 0)
With cht.SeriesCollection(1)
'loop though the points and apply the
'corresponding fill color from the cell
For x = 1 To .Points.Count
.Points(x).Format.Fill.ForeColor.RGB = _
rngColors.Cells(x).Interior.Color
Next x
End With
End Sub
the range from which the data are read is in th emoment stated in the code. Is there a chance that it is read from asheet in the worksheet? So that a person can enter A1:C1 and it will place it the way it is in the code in the moment?
I'm not sure how you want to handle the user's input, but of course the range can be an incoming variable. I have it below as a string but elegance would be the range object. Sorry if this is too simple, I'm not sure your question.
Sub SetColorScheme(UserRange As String, cht As Chart, i As Long)
...
'this is the range of cells which has the colors you want to apply
Set rngColors = ThisWorkbook.Sheets("colors").Range(UserRange).Offset(y_off, 0)
...
End Sub
If the user enters "A1:C1" in cell D1 then you can make use of this range with:
Set rngColors = ThisWorkbook.Sheets("colors").Range(Range("D1").Value).Offset(y_off, 0)
' but you should refer to the w/sheet as well
Set rngColors = ThisWorkbook.Sheets("colors") _
.Range(ThisWorkbook.Sheets("colors").Range("D1").Value).Offset(y_off, 0)
Range("D1").Value obtains the text "A1:C1" which is then used to identify this Range.