Trying to create a keno board where a person can press a button and get 20 random highlighted numbers. The keno board goes from A1 to J10 and this is the code im using to randomize.
Sub GetRandomCell()
Dim i As Integer
i = 1
Do While i < 21
Dim RNG As Range
Set RNG = Range("A1:j10")
Dim randomCell As Long
randomCell = Int(Rnd * RNG.Cells.Count) + 1
With RNG.Cells(randomCell)
.Select
.Interior.Color = vbYellow
End With
i = i + 1
Loop
End Sub
The problem I am running into is it doesnt always generate 20 yellow cells. How do I ensure that there is always 20?
Sub GetRandomCell()
Dim i As Integer
Dim RNG As Range
Set RNG = Range("A1:J10")
Dim randomCell As Long
i = 1
Do While i < 21
randomCell = Int(Rnd * RNG.Cells.Count) + 1
If RNG.Cells(randomCell).Interior.Color <> vbYellow Then
RNG.Cells(randomCell).Interior.Color = vbYellow
i = i + 1
End If
Loop
End Sub
As mentioned by #KenWhite, it's possible (even probable with such a relatively small range) that you have a cell "overwriting" it's already yellow color. Just add a test, as above, that first checks the cell color and if not yellow, then make yellow.
Related
I have a spreadsheet that I'm trying to migrate into SQL.
The spreadsheet contains 65k rows of information over two worksheets.
The people operating the spreadsheet have been colouring the font in the rows either red, blue or yellow depending on the status of the record. Each row is a record with personal data etc. so I can't share online.
As part of the migration to SQL I need to add a column with a status field. The status field on each row should contain either 1, 2, 3, or 4 depending on whether the row has a black, red, blue or yellow font.
Based on searching here I believe it might be possible with a VBA function and a formula?
Could anyone help with what to do? I'm ok with Excel but not a power user by any means.
try using something like this in VBA. You will need to add several more ifs based on the colors you have.
CurrentSheetText="Sheet1"
LastRow = Sheets(CurrentSheetText).Cells.SpecialCells(xlCellTypeLastCell).Row
for iter = 1 to LastRow
if Sheets(CurrentSheetText).Cells(iter, 1).Interior.Color = RGB(255, 255, 0) Then
Sheets(CurrentSheetText).Cells(iter,5).value =1
End if
Next iter
This is very easily implemented with VBA. Due to the lack of information in the post, I can only write you a crude script
Sub AddCol()
Dim wb As Workbook
Dim ws As Worksheet
Dim LRow As Long, i As Long
'Target workbook
Set wb = Workbooks("NAME")
'Target worksheet
Set ws = wb.Sheets(INDEX)
'Target column
target_col = 1
'Output column
output_col = 10
With ws
'Find last row in sheet based on column A
LRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through row 1 through LRow
For i = 1 To LRow
'populate output col based on target col's font colour
If .Cells(i, target_col).Font.Color = vbBlack Then
.Cells(i, output_col).Value = 1
ElseIf .Cells(i, target_col).Font.Color = vbRed Then
.Cells(i, output_col).Value = 2
ElseIf .Cells(i, target_col).Font.Color = vbBlue Then
.Cells(i, output_col).Value = 3
ElseIf .Cells(i, target_col).Font.Color = vbYellow Then
.Cells(i, output_col).Value = 4
End If
Next i
End With
End Sub
Many thanks for all the help!
It seems there is a very simple way to do this without any code!
I was able to use the filter function by highlighting the cheet and sorting by colour. Once I had all the red text together I was able to just add a 1 to each row and fill down.
Try the next function, please. It will return an array with the settled codes for analyzed colors. It take in consideration all standard nuances (especially for blue) of the colors in discussion:
Function colorNo(sh As Worksheet) As Variant
Dim lastR As Long, cel As Range, arr, k As Long
lastR = sh.Range("A" & rows.count).End(xlUp).row
ReDim arr(lastR - 2)
For Each cel In sh.Range("A2:A" & lastR)
Select Case cel.Font.Color
Case vbRed, 49407: arr(k) = 2: k = k + 1
Case vbBlue, 12611584, 6567712, 9851952, 14395790: arr(k) = 3: k = k + 1
Case vbYellow: arr(k) = 4: k = k + 1
Case Else: arr(k) = 1: k = k + 1
End Select
Next
colorNo = arr
End Function
The above code considers all other colors like being Black!
If in the future you will need some other colors, you should fill appropriate Case newColor lines...
It can be tested/used in this way:
Sub testColorNo()
Dim sh As Worksheet, arrCol As Variant
Set sh = ActiveSheet
arrCol = colorNo(sh)
'the array can be used like it is
'or its value can be dropped in the last empty column
'un comment the next line if you want to visually see the returned array
'but only on testing small range. Otherwise, it will be a huge string...
'Debug.Print Join(arrCol, ","): you can see the array content in Immediate Window
sh.cells(2, sh.UsedRange.Columns.count + 1).Resize(UBound(arrCol) + 1, 1).Value = _
WorksheetFunction.Transpose(arrCol)
End Sub
This should work:
Sub SubColor()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Checking font's color.
Select Case RngTarget.Font.Color
'In Case is black.
Case Is = 0
RngFirstAnswer.Offset(DblRow, 0) = 0
'In case is red.
Case Is = 255
RngFirstAnswer.Offset(DblRow, 0) = 1
'In case is blue.
Case Is = 12611584
RngFirstAnswer.Offset(DblRow, 0) = 2
'In case is yellow.
Case Is = 65535
RngFirstAnswer.Offset(DblRow, 0) = 3
'In other cases.
Case Else
RngFirstAnswer.Offset(DblRow, 0) = "Unclassified"
End Select
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Edit the variables accordingly.
If you need to know what number refers to each of the fonts' color you have, use this:
Sub SubFontColourNumber()
'Declarations.
Dim RngColouredRange As Range
Dim RngFirstAnswer As Range
Dim RngTarget As Range
Dim DblRow As Double
'Setting variables.
Set RngColouredRange = Range("M1:M5")
Set RngFirstAnswer = Range("N1")
'Covering each cell in RngColouredRange.
For Each RngTarget In RngColouredRange
'Reporting the font's color.
RngFirstAnswer.Offset(DblRow, 0) = RngTarget.Font.Color
'Increasing DblRow.
DblRow = DblRow + 1
Next
End Sub
Like before, edit the variables accordingly.
I want to read through multiple cells in a row and depending if they are all formatted green, turn a separate cell green.
If one cell in the row is either red or has no colour the cell will remain with red or no colour, then loop through my table to read each row and return a format in one column of cells.
And when I click my update button which brings new data into the table, the column of cells will reset to no colour then be formatted.
[![enter image description here][1]][1]
Sub CS_Click()
Range("D6:D37").Interior.ColorIndex = 0
Dim Range1 As Range
Dim Range2 As Range
For RR = 1 To 33
For CC = 1 To 31
Set Range1 = Cells(RR + 5, CC + 6)
Set Range2 = Cells(RR + 5, CC + 3)
If Range1.Interior.ColorIndex = 0 Then
Range2.Interior.ColorIndex = 0
ElseIf Range1.Interior.ColorIndex = 38 Then
Range2.Interior.ColorIndex = 38
ElseIf Range1.Interior.ColorIndex = 50 Then
Range2.Interior.ColorIndex = 50
End If
Next
Next
End Sub
I think you could use something like the following. This will loop through a range and test each row in the range for the ColorIndex of that row. It will then update a destination row with the ColorIndex of your choice
Sub CS_Click()
Dim rng As Range, RowRng As Range
Dim c As Range
Dim RowNo As Long
Dim ClrIndex As Long
Dim ChangeClr As Boolean
' The range of your source data
Set rng = ActiveSheet.Range("G6:AM37")
For Each c In rng.Columns(1).Cells
ClrIndex = -4142
ChangeClr = False
RowNo = c.Row - rng.Cells(1).Row + 1
On Error Resume Next
Set RowRng = Nothing
Set RowRng = rng.Rows(RowNo).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not RowRng Is Nothing Then
Select Case RowRng.Interior.ColorIndex
' Case 50
Case 50
ClrIndex = 50
ChangeClr = True
' Blank rows
Case -4142
ChangeClr = False
' Others not defined, Null (Mixed color rows) and color 38 rows
Case Else:
ClrIndex = 38
ChangeClr = True
End Select
If ChangeClr = True Then
' Update the 'rng.Coloumns.Count + 1' with the offset of your destination cell
c.Offset(0, -3).Interior.ColorIndex = ClrIndex
End If
End If
Next c
End Sub
I think your code can be simplified to:
Sub CS_Click()
Range("D6:D37").Interior.ColorIndex = 0
For RR = 1 To 33
Set Range2 = Cells(RR + 5, 4)
For CC = 1 To 31
Set Range1 = Cells(RR + 5, CC + 6)
c = Range1.Interior.ColorIndex
If c = 38 Or c = 50 Then
Range2.Interior.ColorIndex = c
Exit For ' remove this line as necessary
End If
Next
Next
End Sub
If you leave the Exit For line in, then the colour in column D will change based on the first pink or green cell it gets to. If you remove it, it will change the colour on each pink or green cell - resulting in column D representing the last green or pink colour it detected.
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
To get a random cell in a filtered range I use this method below but it sometimes selects hidden ones.
How can I restrict random selection to select visible cells?
Set areaRng = Sheet1.Range("table_area").SpecialCells(xlCellTypeVisible)
Dim randomCell As Long
randomCell = Int(Rnd * areaRng.Cells.Count) + 1
On Error Resume Next
With areaRng.Cells(randomCell)
.Select
End With`
Randomize a position within the entire range and cross check that for being within the visible cells.
Dim areaAllRng As Range, areaVisibleRng As Range
Dim randomCell As Long
With Sheet6
Set areaAllRng = .Range("table_area").Cells
Set areaVisibleRng = .Range("table_area").SpecialCells(xlCellTypeVisible)
randomCell = Int(Rnd * areaAllRng.Cells.Count) + 1
Do While Intersect(areaAllRng.Cells(randomCell), areaVisibleRng) Is Nothing
'Debug.Print areaAllRng.Cells(randomCell).Address(0, 0)
randomCell = Int(Rnd * areaAllRng.Cells.Count) + 1
Loop
Debug.Print areaAllRng.Cells(randomCell).Address(0, 0)
areaAllRng.Cells(randomCell).Select
End With
Alternative method that doesn't bias the result but still utilises the Areas property thus avoiding the risk of run time blowing out on random chance
Sub Demo()
Dim rngVisible As Range
Dim arr As Range
Dim CellsToCount As Long
Dim RandCell As Range
Set rngVisible = Sheet1.Range("table_area").SpecialCells(xlCellTypeVisible)
CellsToCount = Int(Rnd * rngVisible.Count) + 1
For Each arr In rngVisible.Areas
If arr.Cells.Count >= CellsToCount Then
Set RandCell = arr.Cells(CellsToCount)
Exit For
Else
CellsToCount = CellsToCount - arr.Cells.Count
End If
Next
RandCell.Select
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