I'm running the following program, and get an overflow error at the first iteration once the program gets to a. From my understanding this shouldn't happen because I'm using Doubles which have a ridiculous amount of capacity, and a Long, but because it's only going up to 100 currently it shouldn't matter, and the code fails long before then. Here is my original inputs:
h0 = 1000, v0 = 0, a0 = g = -9.80665, dt = .01, m = 752.2528, b = .287875
and here's the code:
Sub drag()
Dim h0 As Double
Dim v0 As Double
Dim a0 As Double
Dim dt As Double
Dim m As Double
Dim b As Double
Dim g As Double
Dim i As Long
Dim h As Double
Dim v As Double
Dim a As Double
h0 = Worksheets("Drag").Cells(2, 8).Value
v0 = Worksheets("Drag").Cells(2, 9).Value
a0 = Worksheets("Drag").Cells(2, 10).Value
g = Worksheets("Drag").Cells(2, 10).Value
dt = Worksheets("Drag").Cells(2, 7).Value
m = Worksheets("Drag").Cells(2, 4).Value
b = Worksheets("Drag").Cells(2, 5).Value
Debug.Print h0 & v0 & a0 & dt & m & b
For i = 1 To 100
v = v0 + a0 * dt
h = 0.5 * a0 * (dt ^ 2) + v0 * dt + h0
a = m * g - b * (v ^ 2) 'Line where overflow occurs
v0 = v
h0 = h
a0 = a
Cells(i + 2, 8) = h0
Cells(i + 2, 9) = v0
Cells(i + 2, 10) = a0
Next i
Debug.Print h0 & v0 & a0 & dt & m & b
End Sub
Hope this is an easy fix.
Your overflow happens when i=14 (14th pass through the loop) and when v = -1.689 x 10^209. I don't know what you are trying to do, but v is blowing up. It would help if you describe what you are trying to do. – John Coleman 17 mins ago
#John Coleman I see the problem now, I'm doing the drag equation and I forgot to divide the a term by m, thanks. – Anthrochange 9 mins ago
You have already identified what needs to be done.
Now for the explanation on why the overflow on m * g - b * (v ^ 2). I added a watch as shown below
Consider the before and after screenshot
Before v = v0 + a0 * dt is calculated
After v = v0 + a0 * dt is calculated
What you see here is a very peculiar behaviour. A Type Double changing to an Integer
This is not normal and has been experienced before. Unfortunately this problem exists in Excel for a long time and unfortunately is also present in Excel 2016. It occurs only when you are using very large numbers. These kind of bugs are very rare, but yes, they do exist.
One can have a similar kind of experience when using MOD as mentioned in the below link
The MOD Function
The variable in question that is getting an overflow is v. You defined it as a double, which means you can only put numbers in the range of 1.79769313486232 * 10^308 to 4.94065645841247 * 10^–324. VBA uses 8 bytes to hold the double data. Any number outside of this huge range causes an overflow. (see here for more information about DBA data types)
How big of a number are you expecting? A rough estimate fo the number of atoms in the universe is 1 * 10^82, and the double value range goes to almost 2 *10^308. If you need to work with numbers that large, you're going to have to use a different method because it simply won't fit in the standard VBA data types.
So, I made a fun and simple macro that randomly selects R, G, and B values until it uses every possible combination (skipping repeats), and setting the color values of a 10x10 square with each new color.
The only problem is that I have run into the limit for the number of cell formats. Microsoft says that the limit should be around 64000, but I found it to be exactly 65429 on a blank workbook in Excel 2013.
I've included a clear format code, but it seems to have no effect:
Cells(X, Y).ClearFormats
Microsoft lists some resolutions, but 3 out of the 4 of them are essentially "Don't make too many formats", and the 4th format is to use a third party application.
Is there really nothing that can be done in VBA?
A1:J10 will print a new color
K1 will print the percentage to completion
L1 will print the number of colors used
M1 will print the number of times a color combination is repeated
Dim CA(255, 255, 255) As Integer
Dim CC As Long
Dim RC As Long
Dim R As Integer
Dim G As Integer
Dim B As Integer
Dim X As Integer
Dim Y As Integer
CC = 0
RC = 0
X = 1
Y = 1
Do While ColorCount < 16777216
R = ((Rnd * 256) - 0.5)
G = ((Rnd * 256) - 0.5)
B = ((Rnd * 256) - 0.5)
If CA(R, G, B) <> 1 Then
CA(R, G, B) = 1
'Step down to the next row
'If at the 10th row, jump back to the first and move to the next column
If X < 10 Then
X = X + 1
Else
X = 1
If Y < 10 Then
Y = Y + 1
Else
Y = 1
End If
End If
Cells(X, Y).ClearFormats 'doesn't do what I hope :(
Cells(X, Y).Interior.Color = RGB(R, G, B)
CC = CC + 1
Cells(1, 11).Value = (CC / 16777216) * 100
Cells(1, 12).Value = CC
Else
RC = RC + 1
Cells(1, 13).Value = RC
End If
Loop
There are several ways to resolve this issue, but the cleanest and easiest method is to remove all extra styles (I have seen workbooks with 9000+ styles )
With the following simple VBA code you can remove all non-builtin styles and in the vast majority of cases this fixes the error.
Sub removeStyles()
Dim li as long
On Error Resume Next
With ActiveWorkbook
For li = .Styles.Count To 1 Step -1
If Not .Styles(li).BuiltIn Then
.Styles(li).Delete
End If
Next
End With
End Sub
This is my first foray into user defined functions since Excel 7.0. So I'm pretty sure I'm making a newbie error.
I'm getting a #VALUE error in the cell where I've entered the formula. When I use Error Checking to Show Calculation Steps, it evaluates the functions arguments as the cell references rather than values.
The formula in the cell:
=PavementNPV(P2, U2, T2, R2, Y2, Z2, AA2, I2, J2, K2, B2, W2, V2, X2)
Error checking window says the formula exactly with all cell references underline and X2 italicized. At the bottom is the message that the next evaluation will cause an error. The error is #VALUE.
The values in the cells:
P2 = 10
U2 = 63.17986
T2 = 10
R2 = 3
Y2 = $0.28
Z2 = $1.32
AA2 = $2.58
I2 = 14000
J2 = 45
K2 = 60
B2 = 292
W2 = 73.17986
V2 = 8
X2 = 0.05
The code:
Function PavementNPV(AssumedLife, PvmtCondition, AgeByCondition, Curve, CarVOC As Currency, BusVOC As Currency, TruckVOC As Currency, AvgDailyTraffic, TruckCount, BusCount, SegLength, RestPCTGain, RestAgeByCondition, Rate) As Currency
'Calculate Yr1 restored PCI(PvmtCondition - Pavement Condition Index) value
' =PvmtCondition + Assumed Life
Dim Yr1RestPCI
Yr1RestPCI = PvmtCondition + AssumedLife
'For each year of Assumed life, calculate doNothingTotalAnnualVOCIncreaseRange and restoredTotalAnnualVOCIncreaseRange:
' =365*(CarVOCIncrease% as (Application.WorksheetFunction.VLOOKUP((PCIofYr as (If Yr1 then PvmtCondition, else 100*(1/(1+EXP((AgeByCondition+year(e.g. 2)-1)/Application.WorksheetFunction.VLOOKUP(Curve,Table4[#All],2,FALSE)-Application.WorksheetFunction.VLOOKUP(Curve,Table4[#All],3,FALSE))))*Application.WorksheetFunction.VLOOKUP(Curve,Table4[#All],4,FALSE)))),'User Cost'!$BC$5:$BF$151,2))*CarVOC*AvgDailyTraffic+BusVOCIncrease%*BusVOC+TruckVOCIncrease%*TruckVOC)*SegLength/5280)
Dim arydoNothingPCI()
ReDim arydoNothingPCI(1 To AssumedLife)
Dim aryRestoredPCI()
ReDim aryRestoredPCI(1 To AssumedLife)
Dim arydoNothingVOCIncrease() As Currency
ReDim arydoNothingVOCIncrease(1 To AssumedLife)
Dim aryRestoredVOCIncrease() As Currency
ReDim aryRestoredVOCIncrease(1 To AssumedLife)
Dim i
arydoNothingPCI(1) = PvmtCondition
aryRestoredPCI(1) = Yr1RestPCI
For i = 2 To AssumedLife
arydoNothingPCI(i) = 100 * (1 / (1 + Application.WorksheetFunction.Exp((AgeByCondition + i) - 1) / Application.WorksheetFunction.VLookup(Curve, "Table4[#All]", 2, False) - Application.WorksheetFunction.VLookup(Curve, "Table4[#All]", 3, False))) * Application.WorksheetFunction.VLookup(Curve, "Table4[#All]", 4, False)
aryRestoredPCI(i) = 100 * (1 / (1 + Application.WorksheetFunction.Exp((RestAgeByCondition + i) - 1) / Application.WorksheetFunction.VLookup(Curve, "Table4[#All]", 2, False) - Application.WorksheetFunction.VLookup(Curve, "Table4[#All]", 3, False))) * Application.WorksheetFunction.VLookup(Curve, "Table4[#All]", 4, False)
Next
'Testing function so far by asking it to return something simple
PavementNPV = CarVOC
'Calculate Total PV Benefits by calculating NPV of doNothing minus NPV or restored
' =Application.WorksheetFunction.NPV(rate,doNothingTotalAnnualVOCIncreaseRange)- Application.WorksheetFunction.NPV(rate,restoredTotalAnnualVOCIncreaseRange)
' or for each NPV =(Yr1VOCIncrease/(1+rate)^1)+(Yr2VOCIncrease/(1+rate)^2)+(Yr3VOCIncrease/(1+rate)^3) etc for all years
End Function
I originally had all of the data types defined, but removed those as my first troubleshooting step. I also originally had the formula entered using Table references (e.g. [#columnname]). I would love to be able to return to that for readability.
Please let me know if you need any additional information to help. Thank you in advance.
Your parameters Arg2 of WorksheetFunction.VLookup are not correct. They can't be strings.
Use
Application.WorksheetFunction.VLookup(Curve, Application.Range("Table4[#All]"), 2, False)
for example.
Another error could be that the WorksheetFunction.VLookup returns the #N/A error because the lookup value could not be found within the table array. In this case the function breaks at this point and returns #Value also. This you could avoid using On Error Resume Next before the calls of WorksheetFunction.VLookup and On Error GoTo 0 after them.
Hint to debug: Have the VBA Editor open. Set a breakpoint somewhere in the function's body. Call the function by input it as formula in a cell. The code stops at the breakpoint. Change to the VBA Editor window and step through the code.
I'm looking for a way to apply a color scale to a set of cells via VBA code but not by applying some conditional formatting... I want to apply them as static colors (InteriorColor)
I've searched plenty of excel sites, google and stackoverflow and found nothing :(
For my situation if you look at the following picture:
You can see I've given it a color scale, in this example though I have done the color scale via Conditional formatting. I want to create the color scale via VBA but it must avoid using conditional formatting, I want to assign interior colors to the cells so that the colors are static which makes them visible on all mobile excel viewers, faster, won't change if I was to remove any numbers/rows.
Here are some example data Just save it in a csv and open it in excel to see the data in excel :P:
Data 1 (Yes there are blanks),Data 2,Data 3,Data 4,Data 5,Data 6
155.7321504,144.6395913,1,-4,-9.3844,0.255813953
113.0646481,120.1609771,5,-2,-2.5874,0.088082902
126.7759917,125.3691519,2,0,-0.0004,0.107843137
,0,7,,,0.035714286
123.0716084,118.0409686,4,0,0.3236,0.118881119
132.4137536,126.5740362,3,-2,-3.8814,0.090909091
70,105.9874422,6,-1,-0.3234,0.103896104
I do use the following in python but obviously I can't use this code in VBA, the following code successfully assigns hex colors to the numbers from a predefined array of 50 colors so it's pretty accurate.
def mapValues(values):
nValues = np.asarray(values, dtype="|S8")
mask = (nValues != '')
maskedValues = [float(i.split('%')[0]) for i in nValues[mask]]
colorMap = np.array(['#F8696B', '#F86E6C', '#F8736D', '#F8786E', '#F97E6F', '#F98370', '#F98871', '#FA8E72', '#FA9373', '#FA9874', '#FA9E75', '#FBA376', '#FBA877', '#FBAD78', '#FCB379', '#FCB87A', '#FCBD7B', '#FCC37C', '#FDC87D', '#FDCD7E', '#FDD37F', '#FED880', '#FEDD81', '#FEE382', '#FEE883', '#FCEB84', '#F6E984', '#F0E784', '#E9E583', '#E3E383', '#DCE182', '#D6E082', '#D0DE82', '#C9DC81', '#C3DA81', '#BDD881', '#B6D680', '#B0D580', '#AAD380', '#A3D17F', '#9DCF7F', '#96CD7E', '#90CB7E', '#8ACA7E', '#83C87D', '#7DC67D', '#77C47D', '#70C27C', '#6AC07C', '#63BE7B'])
_, bins = np.histogram(maskedValues, 49)
try:
mapped = np.digitize(maskedValues, bins)
except:
mapped = int(0)
nValues[mask] = colorMap[mapped - 1]
nValues[~mask] = "#808080"
return nValues.tolist()
Anyone have any ideas or has anyone done this before with VBA.
The following function CalcColorScale will return a color given any two colors and the scale.The scale is the value of your current data relative to the range of data. e.g. if your data is from 0 to 200 then a data value 100 would be scale 50%(.5)
The image shows the result of scaling between red and blue
Public Sub Test()
' Sets cell A1 to background purple
Sheet1.Range("A1").Interior.Color = CalcColorScale(rgbRed, rgbBlue, 0.5)
End Sub
' color1: The starting color as a long
' color2: The end color as a long
' dScale: This is the percentage in decimal of the color.
Public Function CalcColorScale(color1 As Long, color2 As Long, dScale As Double) As Long
' Convert the colors to red, green, blue components
Dim r1 As Long, g1 As Long, b1 As Long
r1 = color1 Mod 256
g1 = (color1 \ 256) Mod 256
b1 = (color1 \ 256 \ 256) Mod 256
Dim r2 As Long, g2 As Long, b2 As Long
r2 = color2 Mod 256
g2 = (color2 \ 256) Mod 256
b2 = (color2 \ 256 \ 256) Mod 256
CalcColorScale = RGB(CalcColorScaleRGB(r1, r2, dScale) _
, CalcColorScaleRGB(g1, g2, dScale) _
, CalcColorScaleRGB(b1, b2, dScale))
End Function
' Calculates the R,G or B for a color between two colors based the percentage between them
' e.g .5 would be halfway between the two colors
Public Function CalcColorScaleRGB(color1 As Long, color2 As Long, dScale As Double) As Long
If color2 < color1 Then
CalcColorScaleRGB = color1 - (Abs(color1 - color2) * dScale)
ElseIf color2 > color1 Then
CalcColorScaleRGB = color1 + (Abs(color1 - color2) * dScale)
Else
CalcColorScaleRGB = color1
End If
End Function
You could always use the python script to generate the hex colors based of csv data and then simply read the csv file holding the generated hex colors and convert rgb then set the interiorcolor to that of the rgb outcome.
Sub HexExample()
Dim i as Long
Dim LastRow as Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow
Cells(i, "B").Interior.Color = HexConv(Cells(i, "A"))
Next
End Sub
Public Function HexConv(ByVal HexColor As String) As String
Dim Red As String
Green As String
Blue As String
HexColor = Replace(HexColor, "#", "")
Red = Val("&H" & Mid(HexColor, 1, 2))
Green = Val("&H" & Mid(HexColor, 3, 2))
Blue = Val("&H" & Mid(HexColor, 5, 2))
HexConv = RGB(Red, Green, Blue)
End Function
Maybe this is what you are looking for:
Sub a()
Dim vCM As Variant
vCM = Array("F8696B", "FED880", "63BE7B") ' as many as you need
' Array's lower bound is 0 unless it is set to another value using Option Base
ActiveCell.Interior.Color = Application.WorksheetFunction.Hex2Dec(CStr(vCM(2))) ' off-green in the active cell
End Sub
If you deside to forgo the Hex and use the color values then the above becomes this
Sub b()
Dim vCM As Variant
vCM = Array(16279915, 16701568, 6536827) ' as many as you need
' Array's lower bound is 0 unless it is set to another value using Option Base
ActiveCell.Interior.Color = vCM(2) ' 6536827 setts an off-green in the active cell
End Sub
In case you do not know how to get the color values, here is the manual process:
Apply an interior color to a cell. Make sure the cell is selected.
In the VBE's Immediate window, execute ?ActiveCell.Interior.Color to get the color number for the interior color you've applied in Step 1.
Good luck.
assuming:
values in A1:A40.
Sub M_snb()
[a1:A40] = [if(A1:A40="",0,A1:A40)]
sn = [index(rank(A1:A40,A1:A40),)]
For j = 1 To UBound(sn)
If Cells(j, 1) <> 0 Then Cells(j, 1).Interior.Color = RGB(Int(sn(j, 1) * 255 / 40), Abs(sn(j, 1) > UBound(sn) \ 2), 255 - Int((sn(j, 1) - 1) * (255 / 40)))
Next
[a1:A40] = [if(A1:A40=0,"",A1:A40)]
End Sub
I've managed to find the correct answer, it's actually rather simple. All you have to do is add conditional formatting and then set the .Interior.Color to the same as what the .DisplayFormat.Interior.Color is and then delete the conditional formatting.
This will do exactly what is requested in the main post; and if you want to do it as a fallback then just don't delete the conditional formatting.
' Select Range
Range("A2:A8").Select
' Set Conditional
Selection.FormatConditions.AddColorScale ColorScaleType:=3
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).ColorScaleCriteria(1).Type = xlConditionValueLowestValue
With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
.Color = 7039480
.TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(2).Type = xlConditionValuePercentile
Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
.Color = 8711167
.TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(3).Type = xlConditionValueHighestValue
With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
.Color = 8109667
.TintAndShade = 0
End With
' Set Static
For i = 1 To Selection.Cells.Count
Selection.Cells(i).Interior.Color = Selection.Cells(i).DisplayFormat.Interior.Color
Next
' Delete Conditional
Selection.Cells.FormatConditions.Delete
Hopefully this helps someone in the future.
The answers above should work. Still, the color is different that from Excel...
To recreate exact the same thing as Excel color formatting, and a little more straight forward in code:
rgb(cr,cg,cb)
color1: red - rgb(248,105,107)
color2:green - rgb(99,190,123)
color3: blue - rgb(255,235,132)
code:
Sub HeatMapOnNOTSorted()
Dim val_min, val_max, val_mid As Double
Dim cr, cg, cy As Double
Dim mysht As Worksheet
Dim TargetRgn As Range
Set mysht = Sheets("Sheet1")
Set TargetRgn = mysht.Range("c4:d9") '<-Change whatever range HERE
'get the min&max value of the range
val_min = Application.WorksheetFunction.Min(TargetRgn)
val_max = Application.WorksheetFunction.Max(TargetRgn)
val_mid = 0.5 * (val_min + val_max)
For Each rgn In TargetRgn
' three color map min-mid-max
' min -> mid: green(99,190,123)-> yellow(255,235,132)
If rgn.Value <= val_mid Then
cr = 99 + (255 - 99) * (rgn.Value - val_min) / (val_mid - val_min)
cg = 190 + (235 - 190) * (rgn.Value - val_min) / (val_mid - val_min)
cb = 123 + (132 - 123) * (rgn.Value - val_min) / (val_mid - val_min)
Else
' mid->max: yellow(255,235,132) -> red(248,105,107)
cr = 255 + (248 - 255) * (rgn.Value - val_mid) / (val_max - val_mid)
cg = 235 + (105 - 235) * (rgn.Value - val_mid) / (val_max - val_mid)
cb = 132 + (107 - 132) * (rgn.Value - val_mid) / (val_max - val_mid)
End If
rgn.Interior.Color = RGB(cr, cg, cb)
Next rgn
End Sub
This function goes through all integers and picks out binary values with only five ones and writes them to the spreadsheet.
To run this For x = 1 To 134217728 would take 2.5 days!!!! Help!
How could I speed this up?
Function D2B(ByVal n As Long) As String
n = Abs(n)
D2B = ""
Do While n > 0
If n = (n \ 2) * 2 Then
D2B = "0" & D2B
Else
D2B = "1" & D2B
n = n - 1
End If
n = n / 2
Loop
End Function
Sub mixtures()
Dim x As Long
Dim y As Integer
Dim fill As String
Dim mask As String
Dim RowOffset As Integer
Dim t As Date
t = Now
fill = ""
For x = 1 To 134217728
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
Debug.Print mask
If x > 100000 Then Exit For
If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _
RowOffset = RowOffset + 1
For y = 1 To Len(mask)
If Len(mask) - Len(WorksheetFunction.Substitute(mask, "1", "")) = 5 Then _
Range("mix").Offset(RowOffset).Cells(y) = Mid(mask, y, 1)
Next
Next
Debug.Print DateDiff("s", Now, t)
End Sub
By first sight guess, I think the problem lies in the fact that you do that cell by cell, which causes many read and write accesses.
You should do it range by range, like
vArr = Range("A1:C1000").Value
' it is array now, do something here effeciently
Range("A1:C1000").Value = vArr
You want find all 28bit numbers with 5 1s
There are 28*27*26*25*24/5/4/3/2=98280 such numbers
The following code took ~10 seconds on my PC:
lineno = 1
For b1 = 0 To 27
For b2 = b1 + 1 To 27
For b3 = b2 + 1 To 27
For b4 = b3 + 1 To 27
For b5 = b4 + 1 To 27
Cells(lineno, 1) = 2 ^ b1 + 2 ^ b2 + 2 ^ b3 + 2 ^ b4 + 2 ^ b5
lineno = lineno + 1
Next
Next
Next
Next
Next
mask = Right(fill & CStr(D2B(x)), Len(fill & CStr(D2B(x))))
The above line of code does the same thing (CStr(D2B(x))) twice.
Store the result of CStr(D2B(x)) in a variable & use that variable in the above line of code.
I've got 2 suggestions:
Get rid of the substitution command by counting the ones/zeroes in D2B and return an empty string if the count does not equal 5
Write these pre-filtered bitstrings to an array first and copy the array directly to the cells when finished.
Something like
ws.Range(ws.cells(1, 1), ws.cells(UBound(dstArr, 1) + 1, UBound(dstArr, 2) + 1)) = dstArr
The array-copy-trick greatly improves performance!