Somebody help! This driving me crazy! I need to find the lowest three calculated values only from cells that have a value in vaNums. I need vaNums / vaDenoms. From that calculation find the three lowest, but ONLY from cells that have a value in vaNums. If a zero is in vaNums then that can be included as one of the three lowest. If vaNums is blank then it should NOT be included as one of the three. Example: 0 / 20 = 0 (that can be included as one of the three lowest) blank / 20 = 0 (that can NOT be included as one of the three lowest) Please help!
Private Sub Worksheet_SelectionChange(ByVal target As Range)
Dim i As Long
Dim vaNums As Variant, vaDenoms As Variant, aDivs() As Variant
Dim wf As WorksheetFunction
Dim lSmall As Long
Dim rRow As Range
Dim rStart As Range
Dim iCount As Integer
Const lCols As Long = 10
Const lMarkcnt As Long = 3
Set wf = Application.WorksheetFunction
Set rRow = target.Cells(1).Offset(0, 1).Resize(1, lCols)
Set rStart = Me.Cells(1, 5)
iCount = wf.CountA(rRow, ">0")
If Not Intersect(target.Cells(1), Me.Range("D3", Me.Range("D3").End(xlDown))) Is Nothing Then
If iCount > 4 Then
Set rRow = target.Cells(1).Offset(0, 1).Resize(1, iCount)
rStart.Resize(1, lCols).Interior.ColorIndex = xlNone
rStart.Resize(1, lCols).Font.ColorIndex = xlAutomatic
vaNums = rRow.Value
vaDenoms = rStart.Offset(1, 0).Resize(1, lCols).Value
ReDim aDivs(LBound(vaNums, 2) To UBound(vaNums, 2))
For i = LBound(vaNums, 2) To UBound(vaNums, 2)
aDivs(i) = vaNums(1, i) / vaDenoms(1, i) + (i / 10000)
Next i
For i = 1 To 3
lSmall = wf.Match(wf.Small(aDivs, i), aDivs, False)
rStart.Offset(0, lSmall - 1).Interior.Color = 6299648
rStart.Offset(0, lSmall - 1).Font.ThemeColor = xlThemeColorDark1
Next i
Else
rStart.Resize(1, lCols).Interior.ColorIndex = xlNone
rStart.Resize(1, lCols).Font.ColorIndex = xlAutomatic
End If
Else
rStart.Resize(1, lCols).Interior.ColorIndex = xlNone
rStart.Resize(1, lCols).Font.ColorIndex = xlAutomatic
End If
End Sub
Worksheet calculation to ignore blanks - VBA
I need to find the lowest three calculated values only from cells that have a value in vaNums.
If vaNums is blank then it should NOT be included as one of the three.
Rather simple isn't it if I have understood you correctly? Use .SpecialCells. It returns a Range object that represents all the cells that match the specified type and value.
Syntax
expression.SpecialCells(Type, Value)
Read up more about it in the Inbuilt Help.
Let's say your range is A1:D10
Simply use this
Sub Sample()
Dim rng As Range, aCell As Range
Dim MyAr As Variant
Dim i As Long
'~~> Change worksheet name and range as applicable
With ThisWorkbook.Sheets("Sheet2").Range("A1:D10")
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
ReDim MyAr(1 To rng.Cells.Count)
i = 1
For Each aCell In rng
MyAr(i) = aCell.Value
i = i + 1
Next
For i = LBound(MyAr) To UBound(MyAr)
Debug.Print MyAr(i)
Next
End With
End Sub
Screenshot:
This is the portion of code that I needed. Hopefully, it makes sense apart from the broader context:
For i = LBound(vaNums, 2) To UBound(vaNums, 2)
If IsEmpty(vaNums(1, i)) Then
aDivs(i) = Empty
Else
aDivs(i) = vaNums(1, i) / vaDenoms(1, i) + (i / 10000)
End If
Next I
The first code I posted was given by another. I just needed to tweak it. Thanks to everyone who helped!
Related
I have this worksheet and i need to compare the "venda" values with "esperado".
If Vendas > Esperado i need to paint the status cell with green, if Vendas < Esperado it will be red
Is there a way to make this process entirely on vba? I am still learning this tool
Please, use the next code. It will create two Union ranges (for each cell interior color type), according to the required condition and color their interior at the code end, at once. That's why it will be fast enough for reasonable ranges number of rows. If huge ranges, I can supply a different solution:
Sub PaintCells()
Dim sh As Worksheet, lastR As Long, arr, rngGreen As Range, rngRed As Range, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("B2:C" & lastR).Value2
For i = 1 To UBound(arr)
If arr(i, 1) > arr(i, 2) Then
addURange rngGreen, sh.Range("D" & i + 1)
ElseIf arr(i, 1) < arr(i, 2) Then
addURange rngRed, sh.Range("D" & i + 1)
End If
Next i
If Not rngGreen Is Nothing Then rngGreen.Interior.Color = vbGreen
If Not rngRed Is Nothing Then rngRed.Interior.Color = vbRed
End Sub
Sub addURange(rngU As Range, rngAdd As Range)
If rngU Is Nothing Then
Set rngU = rngAdd
Else
Set rngU = Application.Union(rngU, rngAdd)
End If
End Sub
Sub ValiaFuncionario()
Dim tables As Range
Set table = Range("B8", Range("B8").End(xlToRight).End(xlDown))
For Each Row In table.Rows
If Row.Cells(1, 2).Value < Row.Cells(1, 3) Then
Row.Cells(1, 4).Interior.Color = vbRed
Row.Cells(1, 4).Value = "ABAIXO"
Else
Row.Cells(1, 4).Interior.Color = vbGreen
Row.Cells(1, 4).Value = "ACIMA"
End If
Next Row
End Sub
i did like this and it worked
I'm trying to perform an action in VBA on a range of cells. I would like the selection of the cells to be random not in the order of how the range is setup.
Sub Solver_Step_Evo()
Set Rng = GetRange(ThisWorkbook.ActiveSheet.Range("Variable_Range"))
For Each i In Rng
'perform an action on I where I is randomly selected.
Next i
End Sub
My preference is it randomizes the order not just randomly select a cell where a cell can be picked more than once.
Thanks in advance.
Here's a possible solution. I add all of the cells in the relevant range to a collection. Then, I navigate the collection using random indexes. Once an index has been visited, I remove it from the collection and repeat the process.
Does this work for you?
Edit: No need to call the c.Count method for each iteration. We can manage this ourselves ourselves. It would likely be a bit more efficient than calling the object's method.
Sub SuperTester()
Dim c As Collection
Dim rng As Range
Dim cel As Range
Dim idx As Long
Dim remainingCount As Long
Set rng = Range("A2:A17")
Set c = New Collection
For Each cel In rng
c.Add cel
Next cel
remainingCount = c.Count
While remainingCount > 0
idx = WorksheetFunction.RandBetween(1, c.Count)
Debug.Print c.Item(idx).Address
c.Remove idx
remainingCount = remainingCount - 1
Wend
End Sub
You can use WorksheetFunction.RandBetween to get random number between 2 numbers. The numbers will not be unique though. If you want unique then you will have to use a slightly different approach.
Option Explicit
Sub Solver_Step_Evo()
Dim Rng As Range
Set Rng = GetRange(ThisWorkbook.ActiveSheet.Range("Variable_Range"))
Dim lowerBound As Long: lowerBound = 1
Dim UpperBound As Long: UpperBound = Rng.Cells.Count
Dim randomI As Long
Dim i As Long
For i = lowerBound To UpperBound
randomI = Application.WorksheetFunction.RandBetween(lowerBound, UpperBound)
Debug.Print randomI
Next i
End Sub
Try the next function, please:
Function RndCell(rng As Range) As Range
Dim rndRow As Long, rndCol As Long
rndRow = WorksheetFunction.RandBetween(1, rng.rows.count)
rndCol = WorksheetFunction.RandBetween(1, rng.Columns.count)
Set RndCell = rng.cells(rndRow, rndCol)
End Function
It can be tested using the next simple sub:
Sub testSelectRandomCell()
Dim rng As Range
Set rng = Range("A2:D10")
RndCell(rng).Select
End Sub
Edited:
If the random selected cells should not repeat, the function can be adapted in the next way (using a Static array to keep the already selected cells):
Function RndCellOnce(rng As Range, Optional boolClear As Boolean = False) As Range
Dim rndRow As Long, rndCol As Long, k As Long, El, arr1
Static arr
If boolClear And IsArray(arr) Then Erase arr
DoItAgain:
rndRow = WorksheetFunction.RandBetween(1, rng.rows.count)
rndCol = WorksheetFunction.RandBetween(1, rng.Columns.count)
If IsArray(arr) Then
If UBound(arr) = rng.cells.count - 1 Then
rng.Interior.Color = xlNone
ReDim arr(0): GoTo Over
End If
For Each El In arr
If El <> "" Then
arr1 = Split(El, "|")
If CLng(arr1(0)) = rndRow And CLng(arr1(1)) = rndCol Then GoTo DoItAgain
End If
Next El
ReDim Preserve arr(UBound(arr) + 1)
Else
ReDim arr(0)
End If
Over:
arr(UBound(arr)) = rndRow & "|" & rndCol
Set RndCellOnce = rng.cells(rndRow, rndCol)
End Function
It can be tested with the next Sub. In order to visually check it, each selected cell will get a yellow interior color. When all the range cells will be selected (one by one), the static array will be erased and the interior color will be cleaned:
Sub testSelectRandomCell()
Dim rng As Range
Set rng = Range("A2:D10")
With RndCellOnce(rng)
.Interior.Color = vbYellow
.Select
End With
End Sub
I made a macro that calculates some formulas, that are stored as text at first in one column, by replacing some codes by their associated int values and later print the result in the desired column.
e.g. dAGR99001/dAGR99002 is replaced by 2/2 since their values for certain month/year are both 2, later this text formula converted into a proper formula by adding the equal sign at the beginning and prints the result of it in another column.
My problem is that when replacing the codes by their associated int values, Excel automatically converts it to a date. For example on the above formula, it should be replaced by 2/2 but instead, it's returning 2/Feb (2/Fev in Portuguese) as in 2/2/2019 and when later calculating it the final result is 43498 (days since 1/1/1900).
How can I prevent this from happening?
→
Note that both the column where the text formula is and the associated int values of the codes are stored has General format. I also tried to save them as Number or Text but the problem still persisted.
This is my code
Sub Looper()
Dim x As Integer
For x = 10 To 60
getformulas x
Next x
End Sub
Sub getformulas(MonthNum As Integer)
Dim wb As Workbook
Dim wsLookup As Worksheet
Dim wsData As Worksheet
Dim wsPaste As Worksheet
Dim aLookup() As Variant
Dim aData() As Variant
Dim lCodesLookupCol As Long
Dim lCodesConvertCol As Long
Dim i As Long
Dim lrow As Long
Call OptimizeCode_Begin
With Sheets("Variaveis")
lrow = .Range("A:BA").Find(What:="", after:=.Range("A2"), searchdirection:=xlPrevious).Row
End With
Set wb = ActiveWorkbook
Set wsData = wb.Worksheets("Indicadores")
Set wsLookup = wb.Worksheets("Variaveis")
Set wsPaste = wb.Worksheets("Formulas")
aLookup = wsLookup.Range("A2:BA" & lrow) '("A2:AO441")
lCodesLookupCol = LBound(aLookup, 2)
lCodesConvertCol = UBound(aLookup, 2)
With wsData.Range("H2", wsData.Cells(wsData.Rows.Count, "H").End(xlUp))
For i = 1 To UBound(aLookup, 1)
.Replace aLookup(i, lCodesLookupCol), aLookup(i, MonthNum - 4), xlPart, , False
Next i
If .Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = .Formula
Else
aData = .Formula
End If
For i = 1 To UBound(aData, 1)
If Len(aData(i, 1)) > 0 And Left(aData(i, 1), 1) <> "=" Then aData(i, 1) = "=" & aData(i, 1)
wsData.Cells(i + 1, MonthNum) = aData(i, 1)
If Left(aData(i, 1), 1) <> "=" Then
wsData.Cells(i + 1, MonthNum).Value = "Error"
End If
On Error Resume Next
Next i
End If
Call OptimizeCode_End
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End With
Worksheets("Formulas").Range("B2:B228").Copy
Worksheets("Indicadores").Range("H2:H228").PasteSpecial Paste:=xlPasteFormulas
Application.Goto Worksheets("Indicadores").Cells(2, 6)
End Sub
How do I highlight rows with different colors by groups of duplicates?
I don't care about which colors are used per se, I just want the duplicate rows one color, and the next set of duplicates another color.
For example, if I wanted the '1s' green, the '2s' blue and so on. It goes up to 120 in my column.
Thank you.
The solution by Gowtham is only specific to numbers and uses VBA. You can use the following workaround that works with any type of data and doesn't need VBA.
We could use another column that generates a unique value for all the duplicates using a formula and use the "Conditional Formatting > Color Scales" for that column. Screenshot below.
The formula that you can use is
"=ROW(INDEX(A$2:A$12,MATCH(A2,A$2:A$12,0)))"
In the above formula, A$2:A$12 is the range that we want to search for duplicates.
The formula basically searches for the first instance of the duplicate value in the given range and inputs the row number of that first instance.
P.S: In the above formula, the range "A$2:A$12" is a fixed range, using the above formula in a Table is much simpler as a Table Range is dynamic
One other benefit of using Table is that we can even sort the data to group the duplicate values together
=ROW(INDEX([Column1],MATCH(A2,[Column1],0)))
Try out this simple code and modify it per your needs. Its quite self explanatory,
Sub dupColors()
Dim i As Long, cIndex As Long
cIndex = 3
Cells(1, 1).Interior.ColorIndex = cIndex
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = Cells(i + 1, 1) Then
Cells(i + 1, 1).Interior.ColorIndex = cIndex
Else
If Cells(i + 1, 1) <> "" Then
cIndex = cIndex + 1
Cells(i + 1, 1).Interior.ColorIndex = cIndex
End If
End If
Next i
End Sub
Gowtham's answer is great, and I wouldn't have figured out the below without them! I had the same need for unique color assignment, however, I needed more variance than the 56 colors that colorindex provides, so I slightly modified Gowtham's code to provide a bit more variability by using RandBetween along with RGB to create randomized colors via randomized red, blue, and green values.
I kept the color range between 120 & 255, since some of the lower values could result in cells that were too dark to read, but you can certainly customize to your liking. The code below can certainly be improved upon, as I'm no expert, but it was able to obtain the 100+ colors needed.
EDIT: I will add that there is a possibility that RGB values could overlap. I just needed to color-code for visual aid; but if you will need strict unique color values, this code will not guarantee that.
Dim rCount, RandCol1, RandCol2, RandCol3, i As Long
rCount = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To rCount
If Sheet1.Cells(i, 1) = Sheet1.Cells(i + 1, 1) Then
Sheet1.Cells(i + 1, 1).Interior.Color = RGB(RandCol1, RandCol2, RandCol3)
Else
If Sheet1.Cells(i + 1, 1) <> "" Then
RandCol1 = WorksheetFunction.RandBetween(120, 255)
RandCol2 = WorksheetFunction.RandBetween(120, 255)
RandCol3 = WorksheetFunction.RandBetween(120, 255)
Sheet1.Cells(i + 1, 1).Interior.Color = RGB(RandCol1, RandCol2, RandCol3)
End If
End If
Next i
I found this VBA in https://www.extendoffice.com/documents/excel/3772-excel-highlight-duplicate-values-in-different-colors.html:
Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
Next
End Sub
Found this code for excel VBA that worked to organize a large number of duplicates in different colors.
`Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20171222
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Range("M10:P10010")
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
If xCell.Value <> "" Then
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.Color = RGB(xRed, xGreen, xBlue)
xCell.Interior.Color = xCellPre.Interior.Color
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
xRed = Application.WorksheetFunction.RandBetween(0, 255)
xGreen = Application.WorksheetFunction.RandBetween(0, 255)
xBlue = Application.WorksheetFunction.RandBetween(0, 255)
On Error GoTo 0
End If
Next
End Sub
So here is the following VBA code I'm currently using. It works perfectly but I need to expand the range to check additional cells but some of those cells could contain empty cells and I don't want to select those.
Is there a way to bypass those empty cells?
Dim RNG1 As Range
Set RNG1 = Range("H1:H30")
Dim randomCell1 As Long
randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1
With RNG1.Cells(randomCell1)
.Select
'will do something else here, like copy the cell, fill the cell with a color, etc
End With
This should pick only non-empty cells:
Sub marine()
Dim RNG1 As Range, r As Range, c As Collection
Set c = New Collection
Set RNG1 = Range("H1:H30")
For Each r In RNG1
If r.Value <> "" Then
c.Add r
End If
Next r
Dim N As Long
N = Application.WorksheetFunction.RandBetween(1, c.Count)
Set rselect = c.Item(N)
rselect.Select
End Sub
NOTE:
This is an example of a general technique. To make a random pick from a subset of a range, collect the subset and pick from the Collection.
If the values in column H were XlConstants then something like this using SpecialCells
Sub Option_B()
Dim rng1 As Range
Dim rng2 As Range
Dim lngCel As Long
On Error Resume Next
Set rng1 = Range("H1:H30").SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
Dim randomCell1 As Long
randomCell1 = Int(Rnd * rng1.Cells.Count) + 1
For Each rng2 In rng1.Cells
'kludgy as there will be multiple areas in a SpecialFCells range with blank cells
lngCel = lngCel + 1
If lngCel = randomCell1 Then
Application.Goto rng2
Exit For
End If
Next
End Sub
A bit too late but no harm in posting :)
Sub test()
Dim rng As Range, cel As Range
Dim NErng
Dim i As Integer
Set rng = Range("A1:A15")
For Each cel In rng
If Len(cel) <> 0 Then
If IsArray(NErng) Then
ReDim Preserve NErng(UBound(NErng) + 1)
NErng(UBound(NErng)) = cel.Address
ElseIf IsEmpty(NErng) Then
NErng = cel.Address
Else
NErng = Array(NErng, cel.Address)
End If
End If
Next
i = Int((UBound(NErng) - LBound(NErng) + 1) * Rnd + LBound(NErng))
Debug.Print Range(NErng(i)).Address
End Sub
EDIT -- #brettdj is right. This is adjusted to better answer the "skip these cells" question.
Try this out:
DangThisCellIsBlank:
RandomCell = Int(Rnd * RNG1.Cells.Count) + 1
With RNG1.Cells(RandomCell)
If .Value <> "" Then
'do stuff
Else
'go back and pick another cell
GoTo DangThisCellIsBlank
End If
End With
Try with IsEmpty(RNG1.Cells(randomCell1))
Dim RNG1 As Range
Set RNG1 = Range("H1:H30")
Dim randomCell1 As Long
randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1
'Keep Looping until you find a non empty cell
Do While IsEmpty(RNG1.Cells(randomCell1))
randomCell1 = Int(Rnd * RNG1.Cells.Count) + 1
Loop
'================================================
With RNG1.Cells(randomCell1)
.Select
'will do something else here, like copy the cell, fill the cell with a color, etc
End With