VBA Code to add multiple series to a scatter graph - run time 1004 error - excel

I am writing a code to add multiple series to a line graph. I have also put in a counter to make two separate graphs when a minimum value corresponding to a row is met. My VBA skills are very basic and I get a run time 1004 error at the asterisked line:
Dim xrng As Range
Dim yrng As Range
Dim x2rng As Range
Dim y2rng As Range
Dim i As Integer
Dim Rng As Range
Dim l As Integer
Dim k As Integer
Dim i2 As Integer
Worksheets("Template").Activate
Dim lv As String
lv = Worksheets("Template").Range(Worksheets("Template").Range("B11"), Worksheets("Template").Range("B11").End(xlDown)).Find(WorksheetFunction.Small(Worksheets("Template").Range(Worksheets("Template").Range("B11"), Worksheets("Template").Range("B11").End(xlDown)), 1), , , 1).Address
Range(lv).Select
l = ActiveCell.Row
k = Worksheets("Template").Range(Worksheets("Template").Range("B11"), Worksheets("Template").Range("B11").End(xlDown)).Rows.Count
i = 1
i2 = 1
Set xrng = Worksheets("Template").Range("C11:CP11")
Set yrng = Worksheets("Template").Range("C201:CP201")
Set x2rng = xrng.Offset(1, 0)
Set y2rng = xrng.Offset(1, 0)
Dim Chart1 As Chart
Set Chart1 = Charts.Add
With Chart1
Chart1.ChartType = xlXYScatter
Chart1.SeriesCollection.NewSeries
Chart1.SeriesCollection(1).XValues = xrng
Chart1.SeriesCollection(1).Values = yrng
End With
i = i + 1
ITERATE:
If i < l Then
With Chart1
Chart1.SeriesCollection.NewSeries
Chart1.SeriesCollection(i).XValues = x2rng
' pretend the next line is bold
Chart1.SeriesCollection(i).Values = y2rng
x2rng = x2rng.Offset(1, 0)
y2rng = y2rng.Offset(1, 0)
i = i + 1
GoTo ITERATE
End With
End If
If i < k Then
Dim Chart2 As Chart
Set Chart2 = Charts.Add
With Chart2
Chart2.ChartType = xlXYScatter
Chart2.SeriesCollection.NewSeries
Chart2.SeriesCollection(1).XValues = x2rng
Chart2.SeriesCollection(1).Values = y2rng
End With
End If
i2 = i2 + 1
ITERATE2:
If i < k Then
Chart1.SeriesCollection.NewSeries
Chart1.SeriesCollection(i2).XValues = x2rng
Chart1.SeriesCollection(i2).Values = y2rng
x2rng = x2rng.Offset(1, 0)
y2rng = y2rng.Offset(1, 0)
i2 = i2 + 1
GoTo ITERATE2
End If
I am not sure why I am getting this error.
Any help would be appreciated.
Thanks,
Judoo

Related

How to turn a column of data into an 8x12 grid?

I'm trying to put values from 1 column into an 8x12 grid.
With the first value starting in the top left of the grid, moving to the right 12 cells, then offsetting 1 row from starting cell and having the data continue filling cells in this format.
I'm trying to replace
roneWS.Range("E6:N6") = Application.Transpose(ptWS.Range("B4:B13"))
roneWS.Range("C7:N7") = Application.Transpose(ptWS.Range("B14:B25"))
roneWS.Range("C8:N8") = Application.Transpose(ptWS.Range("B26:B37"))
roneWS.Range("C9:N9") = Application.Transpose(ptWS.Range("B38:B49"))
roneWS.Range("C10:N10") = Application.Transpose(ptWS.Range("B50:B61"))
roneWS.Range("C11:N11") = Application.Transpose(ptWS.Range("B62:B73"))
roneWS.Range("C12:N12") = Application.Transpose(ptWS.Range("B74:B85"))
roneWS.Range("C13:N13") = Application.Transpose(ptWS.Range("B86:B97"))
with an array/loop.
I came up with:
Dim ptWS As Worksheet, roneWS As Worksheet, rtwoWS As Worksheet, rthreeWS As Worksheet, rfourWS As Worksheet
Dim ptRng As Range, destRng As Range
Dim i As Integer
Dim ptArr() As Variant
Set ptWS = ThisWorkbook.Worksheets("PT")
Set roneWS = ThisWorkbook.Worksheets("WS1")
Set rtwoWS = ThisWorkbook.Worksheets("WS2")
Set rthreeWS = ThisWorkbook.Worksheets("WS3")
Set rfourWS = ThisWorkbook.Worksheets("WS4")
i = 4
Set ptRng = ptWS.Range("B4:B97") 'data that needs to be moved to other worksheets B4:B97 = 1st WS, C4:C97 = 2nd WS, D4:D97 = 3rd WS, E4:E97 = 4th WS
Set destRng = roneWS.Range("E6") 'destination range for WS1-WS4 starts at E6
ptArr = ptRng.Value 'setting all values for the WS1 to ptArr
For i = LBound(ptArr) To UBound(ptArr)
If ptArr(i, 1) = ptWS.Cells(14, 2) Then 'move my way across the columns until I hit Col O then, offset back to Col C and repeat until the end (N13) is reached
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(26, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(38, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(50, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(62, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(74, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
ElseIf ptArr(i, 1) = ptWS.Cells(86, 2) Then
Set destRng = destRng.Offset(1, -12)
destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
Else: destRng = ptArr(i, 1)
Set destRng = destRng.Offset(0, 1)
End If
Next i
It gives me what I want for WS1. However I have to repeat this for the 3 other worksheets.
For the other 3 worksheets, the total range is the same as posted above, just offset by 1 column.
WS1 = ptWS.Range("B4:B97")
WS2 = ptWS.Range("C4:C97")
WS3 = ptWS.Range("D4:D97")
WS4 = ptWS.Range("E4:E97")
The destination starting point on all 4 worksheets are the same Range(E6").
How do I add a loop through the worksheets once all cells on WS1 have been set, while also offsetting the column by 1 from ptWS. I'm wondering if this can be done without copy/pasting the existing array code 3 more times and just changing the ranges.
I achieved the same result by looping through the data on ptWS by using a series of Do Until loops but then eventually ran into the same issue.
Here's one appraoch:
Sub Tester()
Dim i As Long
For i = 1 To 4
ColToMatrix ThisWorkbook.Worksheets("PT").Range("B4:B97").Offset(0, i - 1), _
ThisWorkbook.Worksheets("WS" & i).Range("C6")
Next i
End Sub
'pass in the column to be mapped and the top-left destination cell for the matrix
Sub ColToMatrix(rngCol As Range, rngTL As Range)
Dim arr, mtx(1 To 8, 1 To 12), i As Long, r As Long, c As Long, n As Long
arr = rngCol.Value
For i = 1 To UBound(arr, 1)
n = i + 2 'account for starting 3 cells in
r = 1 + ((n - 1) \ 12)
c = ((n - 1) Mod 12) + 1
mtx(r, c) = arr(i, 1)
Next i
rngTL.Resize(8, 12).Value = mtx
End Sub
To do this, better way is doing a sub to transpose data, and then call it for every worksheet.
I'm excluding roneWS.Range("E6:N6") = Application.Transpose(ptWS.Range("B4:B13")) because it's not part of the 7x12 array, due to different size (it's 10 values, not 12).
So we focus on 7x12, this part of your code:
roneWS.Range("C7:N7") = Application.Transpose(ptWS.Range("B14:B25"))
roneWS.Range("C8:N8") = Application.Transpose(ptWS.Range("B26:B37"))
roneWS.Range("C9:N9") = Application.Transpose(ptWS.Range("B38:B49"))
roneWS.Range("C10:N10") = Application.Transpose(ptWS.Range("B50:B61"))
roneWS.Range("C11:N11") = Application.Transpose(ptWS.Range("B62:B73"))
roneWS.Range("C12:N12") = Application.Transpose(ptWS.Range("B74:B85"))
roneWS.Range("C13:N13") = Application.Transpose(ptWS.Range("B86:B97"))
This sub will as for:
A source range like ptWS.Range("B14:B97"), 84 values (7x12)
A destiny range like roneWS.Range("C7:N13"), a 7x12 grid
The code is:
Sub GET_VALUES(ByVal vRngSource As Range, ByVal vRngDestiny As Range)
Dim vMatriz As Variant
Dim ZZ As Long
Dim ThisColumn As Long, ThisRow As Long
ThisColumn = 1
ThisRow = 1
vMatriz = vRngSource.Value
For ZZ = 1 To UBound(vMatriz) Step 1
vRngDestiny.Cells(ThisRow, ThisColumn).Value = vMatriz(ZZ, 1)
If ThisColumn = 12 Then
ThisColumn = 1
ThisRow = ThisRow + 1
Else
ThisColumn = ThisColumn + 1
End If
Next ZZ
Erase vMatriz
End Sub
To call it, you can just do:
Sub test()
GET_VALUES Range("B14:B97"), Range("C7:N13")
End Sub
Now you just need to call it once for every worksheet. I would use a For each loop combined with Select Case, so you can choose for every worksheet what to do, like this:
Sub TEST()
Application.ScreenUpdating = False
Dim WK As Worksheet
Dim ptWS As Worksheet
Set ptWS = ThisWorkbook.Worksheets("PT")
For Each WK In ThisWorkbook.Worksheets
Select Case WK.Name
Case "WS1"
GET_VALUES ptWS.Range("B14:B97"), WK.Range("C7:N13")
WK.Range("E6:N6") = Application.Transpose(ptWS.Range("B4:B13"))
Case "WS2"
GET_VALUES ptWS.Range("C14:C97"), WK.Range("C7:N13")
WK.Range("E6:N6") = Application.Transpose(ptWS.Range("C4:C13"))
Case "WS3"
GET_VALUES ptWS.Range("D14:D97"), WK.Range("C7:N13")
WK.Range("E6:N6") = Application.Transpose(ptWS.Range("D4:D13"))
Case "WS4"
GET_VALUES ptWS.Range("E14:E97"), WK.Range("C7:N13")
WK.Range("E6:N6") = Application.Transpose(ptWS.Range("E4:E13"))
Case Else
'we do nothing
End Select
Next WK
Application.ScreenUpdating = True
End Sub
Hope you can adapt this to your needs.

Find 2 cells' values based on max value found in range

I have a multiplication style table with values inside x and y axis'. After the initial macro is run, I want to search for the max value, then find the corresponding x and y cells. Example...
enter image description here
In this example, the red text is the highest value, so it should find the 1 and the .015. But, there are some tables that might return multiple numbers, so I just want to pick the first cell found. Here is the full code.
Private Sub CommandButton6_Click()
Dim c As Range
Dim rng As Range
Dim balanceValue As Range
Dim dayValue As Range
Dim multValue As Range
Dim lCol As Long
Dim lRow As Long
Dim whereRow As Long
Dim AddressOfMaxH As Variant
'Dim AddressOfMaxV As Range
'Set rng = Sheets("MacroTesting").Range("B91:CD110")
Set rng = Sheets("MacroTesting").Range("B91:C92")
Set balanceValue = Sheets("Header").Range("B4")
Set dayValue = Sheets("Header").Range("E17")
Set multValue = Sheets("Header").Range("F17")
getRow = Sheets("MacroTesting").Range("B91").Row
getCol = Sheets("MacroTesting").Range("B91").Column
whereRow = 90
lCol = Cells(whereRow, Columns.Count).End(xlToLeft).Column
rng.Clear
For Each c In rng
If ActiveCell.Column = lCol Then
getRow = getRow + 1
getCol = 2
End If
getRow = Sheets("MacroTesting").Cells(getRow, 1)
dayValue = getRow
getCol = Sheets("MacroTesting").Cells(whereRow, getCol)
multValue = getCol
c = balanceValue.Copy
c.Select
c = FormatCurrency(c, 0)
Selection.PasteSpecial Paste:=xlPasteValues
getCol = ActiveCell.Column + 1
getRow = ActiveCell.Row
Next
With rng.FormatConditions.AddTop10
.TopBottom = xlTop10Top
.Rank = 1
.Percent = False
With .Font
.Bold = True
.ColorIndex = 3
End With
End With
Set AddressOfMaxH = rng.Cells(WorksheetFunction.Match(WorksheetFunction.Max(rng), rng, 0))
Set AddressOfMaxV = rng.Cells(WorksheetFunction.Match(WorksheetFunction.Max(rng), rng, 0))
AddressOfMaxHoriz = Cells(whereRow, AddressOfMaxH.Column)
AddressOfMaxVerti = Cells(AddressOfMaxV.Row, 1)
dayValue = AddressOfMaxVerti
multValue = AddressOfMaxHoriz
Application.CutCopyMode = False
End Sub
Here is the part where I'm trying to find the relevant cell.
Set AddressOfMaxH = rng.Cells(WorksheetFunction.Match(WorksheetFunction.Max(rng), rng, 0))
Set AddressOfMaxV = rng.Cells(WorksheetFunction.Match(WorksheetFunction.Max(rng), rng, 0))
AddressOfMaxHoriz = Cells(whereRow, AddressOfMaxH.Column)
AddressOfMaxVerti = Cells(AddressOfMaxV.Row, 1)
dayValue = AddressOfMaxVerti
multValue = AddressOfMaxHoriz
Dim rng As Range, f As Range
Set rng = Range("C6:G13")
Set f = rng.Find(Application.Max(rng), lookat:=xlWhole)
Debug.Print Cells(rng(1).Row - 1, f.Column).Value 'column header
Debug.Print Cells(f.Row, rng(1).Column - 1).Value 'row header

Trying to make this work for multiple cells

I have made this program that creates groups of 4 cells on sheets 2 and 3 depending on the value of a cell in sheet 1.
Sub Two_of_Two()
Dim Two_by_Two(1 To 6) As Range
Dim Diag1 As Range
Dim Diag2 As Range
Dim Horiz1 As Range
Dim Horiz2 As Range
Dim Vert1 As Range
Dim Vert2 As Range
Dim Share1 As Range
Dim Share2 As Range
Dim TopLeft As Range
Dim BottomRight As Range
Dim Black As Integer
Dim White As Integer
Black = 255
White = 0
Set Diag1 = Sheet1.Range("E17:F18")
Set Diag2 = Sheet1.Range("H17:I18")
Set Horiz1 = Sheet1.Range("E21:F22")
Set Horiz2 = Sheet1.Range("H21:I22")
Set Vert1 = Sheet1.Range("E24:F25")
Set Vert2 = Sheet1.Range("H24:I25")
Set Two_by_Two(1) = Diag1
Set Two_by_Two(2) = Diag2
Set Two_by_Two(3) = Horiz1
Set Two_by_Two(4) = Horiz2
Set Two_by_Two(5) = Vert1
Set Two_by_Two(6) = Vert2
Dim Cell As Range
Dim Subpixel As Range
For Each Cell In Sheet1.Range("A1")
Set Share1 = Sheet2.Range("A1:B2")
Set Share2 = Sheet3.Range("A1:B2")
Share1.Value = Two_by_Two(Int((6 - 1 + 1) * Rnd + 1)).Value
If Cell.Value >= 127.5 Then
Share2.Value = Share1.Value
ElseIf 127.5 > Cell.Value Then
For Each Subpixel In Share1
If Subpixel.Value = Black Then
Sheet3.Cells(Subpixel.Row, Subpixel.Column) = White
ElseIf Subpixel.Value = White Then
Sheet3.Cells(Subpixel.Row, Subpixel.Column) = Black
End If
Next Subpixel
End If
Next Cell
End Sub
I want to make it so that this works for multiple cells. Say once the for loop goes on to the next cell A2, it inputs values into the next 2x2 group of cells along. So if A1 in Sheet 1 corresponds to the range ("A1:B2") in Sheets 2 and 3, then B1 in Sheet 1 would be ("C1:D2") in Sheets 2 and 3.
Can someone please help me with this? Thanks.
I've cleaned up the code quite a bit and looped the Two_by_Two array.
Sub Two_of_Two()
Dim Two_by_Two(1 To 6) As Range
Dim Diag1 As Range: Set Diag1 = Sheet1.Range("E17:F18")
Dim Diag2 As Range: Set Diag2 = Sheet1.Range("H17:I18")
Dim Horiz1 As Range: Set Horiz1 = Sheet1.Range("E21:F22")
Dim Horiz2 As Range: Set Horiz2 = Sheet1.Range("H21:I22")
Dim Vert1 As Range: Set Vert1 = Sheet1.Range("E24:F25")
Dim Vert2 As Range: Set Vert2 = Sheet1.Range("H24:I25")
Dim Share1 As Range: Set Share1 = Sheet2.Range("A1:B2")
Dim Share2 As Range: Set Share2 = Sheet3.Range("A1:B2")
Dim TopLeft, BottomRight, Cell, Subpixel As Range
Dim Black, White, rndval As Integer
Dim i As Long
Black = 255
White = 0
Set Two_by_Two(1) = Diag1
Set Two_by_Two(2) = Diag2
Set Two_by_Two(3) = Horiz1
Set Two_by_Two(4) = Horiz2
Set Two_by_Two(5) = Vert1
Set Two_by_Two(6) = Vert2
rndval = Int(6 * Rnd + 1)
Share1.Value = Two_by_Two(rndval).Value
If Sheet1.Cells(1, 1) >= 127.5 Then
Share2.Value = Share1.Value
Else
Share2.Value = Sheet1.Cells(1, 1)
End If
For Each Subpixel In Share1
If Subpixel.Value = Black Then
Sheet3.Cells(Subpixel.Row, Subpixel.Column) = White
ElseIf Subpixel.Value = White Then
Sheet3.Cells(Subpixel.Row, Subpixel.Column) = Black
End If
Next Subpixel
End Sub

Using the LinEst function and return values in a column of variable length

I am trying to use the LinEst function to take values from a range of rows of data and input them into a new sheet under some headings. I only want to do this for a particular number of rows (up to row number defined as "c". My VBA skills are very basic.
Sub Button7_Click()
Sheets.Add.Name = "Down Sweep Power Law"
Dim xrng As Range, yrng As Range
Dim i As Long
Dim Rng As Range
Dim l As Long
Dim k As Long
Dim i2 As Long
Dim c As Long
Dim j As Long
Dim drop As Range
Dim drop2 As Range
Dim DownSweep As Chart, UpSweep As Chart, cht As Chart
Dim ws As Worksheet, smallest
Dim dsws As Worksheet
Set ws = Worksheets("Template") '<< use variables for worksheets!
Set dsws = Worksheets("Down Sweep Power Law")
Set Rng = ws.Range(ws.Range("B11"), ws.Range("B11").End(xlDown))
smallest = WorksheetFunction.Small(Rng, 1)
l = Rng.Find(what:=smallest, LookIn:=xlValues, lookat:=xlWhole).Row
k = Rng.Rows.Count
c = l - 10
Set xrng = ws.Range("C11:CP11")
Set yrng = ws.Range("C201:CP201")
Set drop = dsws.Range("A2")
Set x2rng = xrng.Offset(1, 0)
Set y2rng = yrng.Offset(1, 0)
Set drop2 = drop.Offset(1, 0)
dsws.Range("A1").Value = "(n-1) Value"
dsws.Range("B1").Value = "log(k) Value"
dsws.Range("C1").Value = "(n-1) Value"
dsws.Range("D1").Value = "n Value"
dsws.Range("E1").Value = "R Value"
If i < c Then
Set drop = Application.LinEst(Log10(yrng), Log10(xrng), True, False)
i = i + 1
End If
ITERATE:
If i < c Then
Set drop2 = Application.LinEst(Log10(y2rng), Log10(x2rng), True, False)
x2rng = x2rng.Offset(1, 0)
y2rng = y2rng.Offset(1, 0)
drop2 = drop2.Offset(1, 0)
i = i + 1
GoTo ITERATE
End If
End Sub
the code runs but when I go on the created sheet, there is a #NAME error (2029) and no values are present.
Is there a way to fix this?
Any help would be appreciated.
I think you have omitted a step from your plan. LinEst returns an array and you want to assign the values in that array to the range Drop. You can't assign the array directly to the range. Please try this code.
Option Explicit
Sub Button7_Click()
Dim xrng As Range, yrng As Range
Dim Drop As Range
Dim Arr As Variant ' LinEst result array
Dim Rng As Range
Dim R As Long
Dim l As Long
Dim k As Long
Dim i2 As Long
Dim c As Long
Dim j As Long
Dim DownSweep As Chart, UpSweep As Chart, cht As Chart
Dim ws As Worksheet, Smallest As Variant
Dim dsws As Worksheet
Set ws = Worksheets("Template") '<< use variables for worksheets!
Sheets.Add.Name = "Down Sweep Power Law"
Set dsws = Worksheets("Down Sweep Power Law")
Set Rng = ws.Range(ws.Range("B11"), ws.Range("B11").End(xlDown))
Smallest = WorksheetFunction.Small(Rng, 1)
l = Rng.Find(what:=Smallest, LookIn:=xlValues, LookAt:=xlWhole).Row
k = Rng.Rows.Count
c = l - 10
Set xrng = ws.Range("C11:CP11")
Set yrng = ws.Range("C201:CP201")
Set Drop = dsws.Range("C2:CP2").Offset(0, -2)
dsws.Range("A1").Value = "(n-1) Value"
dsws.Range("B1").Value = "log(k) Value"
dsws.Range("C1").Value = "(n-1) Value"
dsws.Range("D1").Value = "n Value"
dsws.Range("E1").Value = "R Value"
Do While R < c
Arr = Application.LinEst(Log10(yrng), Log10(xrng), True, False)
Drop.Value = Arr ' or perhaps: = Application.Transpose(Arr)
Set xrng = xrng.Offset(1, 0)
Set yrng = yrng.Offset(1, 0)
Set Drop = Drop.Offset(1, 0)
R = R + 1
Loop
End Sub
I don't know what kind of array LinEst will return. You may have to transpose the result.
I also tried to improve your management of ranges. However, the code is entirely untried, for lack of data. There may be logical errors in my code as well as typos but the syntax should be sound. It may not take you all the way over the finish line but I hope it will help you in your quest.

Coloring Excel cells under conditions

I'm trying to find a code in excel macro that can address the following problem.
If the first column contains any text then highlight the first column cells with a certain color until next text doesn't appear in the same column. When any text appears in the same column, start coloring the cells with different color.
I have to repeat this for all the worksheets in my workbook.
Thanks.
Right now I'm using this macro to colour the cells which are empty
but the problem is the color doesnot change whenever a text is encountered
Sub try()
Dim i As Integer
Dim j As Integer
Dim k As Integer
i = 200
j = 100
k = 5
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
.AutoFilter Field:=1, Criteria1:=""
If WorksheetFunction.CountBlank(.Columns(1)) > 0 Then
.Columns(1).SpecialCells(xlCellTypeBlanks).Interior.Color = RGB(i, j, k)
Else
i = i - 50
j = j - 10
k = 255
End If
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub
Here you go:
Option Explicit
Sub Color_Ranges()
Dim oSheet As Worksheet
Dim oRange As Range
Dim oRange_Color As Range
Dim oBaseCell As Range
Dim lLast_Row As Long
Dim lRange_Rows As Long
Dim iCnt_Values As Integer
Dim iCnt_Intervals As Integer
Dim r As Integer
Dim g As Integer
Dim b As Integer
Dim iCnt As Integer
Set oSheet = ThisWorkbook.Sheets(1)
With oSheet
lLast_Row = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
End With
'Total range you want to color
Set oRange = oSheet.Range(Cells(1, 1), Cells(lLast_Row, 1))
lRange_Rows = oRange.Rows.Count
'Count values
iCnt_Values = WorksheetFunction.CountA(oRange)
'Count intervals
iCnt_Intervals = iCnt_Values - 1
'Generate random colors
r = CInt(Int((255 * Rnd()) + 1))
g = CInt(Int((255 * Rnd()) + 1))
b = CInt(Int((255 * Rnd()) + 1))
Set oBaseCell = oRange.Cells(1, 1)
For iCnt = 1 To iCnt_Intervals
Set oRange_Color = Range(oBaseCell, oBaseCell.End(xlDown))
oRange_Color.Interior.Color = RGB(r, g, b)
r = CInt(Int((255 * Rnd()) + 1))
g = CInt(Int((255 * Rnd()) + 1))
b = CInt(Int((255 * Rnd()) + 1))
Set oBaseCell = oBaseCell.End(xlDown)
Set oRange_Color = Nothing
Next iCnt
End Sub

Resources