apologies if this has already been answered although I have searched and search with no luck. in a nutshell im trying to change the cell colour if that cell value does not match a value in a named range.
I have tried a number of methods although none are working for me , any help from the vba gurus would be greatly appreciated.
essentially I have a list of values on sheet1(Create) G2:G5000 that I need to know when they don't match value on sheet2(lists) S2:S64 <--this has a named range of Make.
please see a copy of my current code below
Sub testMake()
Dim MkData As Range, MkVal As Range
Dim MKArray As Variant
Set MkData = Worksheets("Create").Range("G2:G5000")
Set MkVal = Worksheets("Lists").Range("Make")
For Each MyCell In MkData
If MyCell.Value <> Range("MkVal") Then
MyCell.Interior.ColorIndex = 6
Else
MyCell.Interior.ColorIndex = xlNone
End If
Next
End Sub
Thanks you all for any help in advance, I have been looking at this for a few days now and seem to be no closer than when I started.
While I would use conditional formatting you could slightly adapt your code as below to do this programatically:
Sub testMake()
Dim MkData As Range
Dim MkVal As Range
Dim MKArray As Variant
Dim lngRow As Long
Dim rng1 As Range
Dim rng2 As Range
MKArray = Worksheets("Create").Range("G2:G5000").Value2
Set rng1 = Worksheets("Create").Range("G2")
Set MkVal = Range("Make")
For lngRow = 1 To UBound(MKArray)
If IsError(Application.Match(MKArray(lngRow, 1), MkVal, 0)) Then
If Not rng2 Is Nothing Then
Set rng2 = Union(rng2, rng1.Offset(lngRow - 1, 0))
Else
Set rng2 = rng1.Offset(lngRow - 1, 0)
End If
End If
Next
If Not rng2 Is Nothing Then rng2.Interior.ColorIndex = 6
End Sub
You could be using Worksheet function Vlookup to compare between the two ranges:
Sub testMake()
Dim MkData As Range, MkVal As Range
Dim MKArray As Variant
Dim result As Variant
Set MkData = Worksheets("Create").Range("G2:G5000")
Set MkVal = Worksheets("Lists").Range("Make")
For Each MyCell In MkData
On Error Resume Next
result = Application.WorksheetFunction.VLookup(MyCell, MkVal, 1, False)
If Err <> 0 Then
result = CVErr(xlErrNA)
End If
If Not IsError(result) Then
MyCell.Interior.ColorIndex = xlNone
Else
MyCell.Interior.ColorIndex = 6
End If
Next
End Sub
Related
I am struggling to find any info on the internet to make this work, please help me out.
I would like a function to do the following (summarized below)
As you can see column A3:A7 has a number in each cell and a colour associated with that specific number.
I would like the code to scan through A3:A7 and match the numbers in C3:C7 with the colour that's already applied. (See below for detailed explanation)
For instance, A3 has a value of 1 and is yellow, I would like the code to scan through all numbers in Column C (C3:C7) and identify that C6 is also 1, therefore it will apply yellow to C6.
Initial:
Final:
Also can this be done across two different Sheets.For example lets say A3:A7 is on Sheet1 and I want to find matches in C3:C7 in Sheet2
Sub ColourCells()
Dim Rng1 As Range, Rng2 As Range, Rng2Item As Range
Dim Rng1LRow As Long, Rng2LRow As Long
Dim Rng1Match As Variant
With Worksheets("Sheet1")
Rng2LRow = .Cells(.Rows.Count, 3).End(xlUp).Row
Set Rng2 = .Range("C3:C" & Rng2LRow)
End With
With Worksheets("Sheet2")
Rng1LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Rng1 = .Range("A3:A" & Rng1LRow)
End With
For Each Rng2Item In Rng2
With Rng2Item
Rng1Match = Application.Match(.Value, Rng1, 0)
If IsError(Rng1Match) Then
GoTo NextItem
Else
.Interior.Color = Application.Index(Rng1, Rng1Match, 0).Interior.Color
End If
End With
NextItem:
Next Rng2Item
End Sub
Sub test()
Dim rng1 As Range, rng2 As Range, rng As Range
Set rng1 = Range("A3:A7")
Set rng2 = Range("C3:C7")
For Each rng In rng2
With Application.WorksheetFunction
If .CountIf(rng1, rng.Value) > 0 Then rng.Interior.Color = .Index(rng1, .Match(rng.Value, rng1, 0), 1).Interior.Color
End With
Next rng
Set rng1 = Nothing
Set rng2 = Nothing
End Sub
I need to create a script that will type a value into every colored cell in a given range
I am very new to all of this so forgive my ignorance.
From the reading I've done I've come up with this
Sub Macro1()
Dim colors As Range, found As Boolean
Set colors = ActiveSheet.Range("D19:CV68")
found = VBA.IsNull(colors.DisplayFormat.Interior.ColorIndex)
colors = IIf(found, "1", " ")
End Sub
This gets me very close to what I need but instead of placing the 1 in just the colored cells it places the one in every cell in the range.
I'm sure there is a very basic way to do this that I am just not aware of.
I appreciate any help that I can get.
Thanks!
You need to iterate through each cell in the range testing for no color.
Dim colors As Range
Dim cell As Range
Set colors = Range("D19:CV68")
For Each cell In colors
If cell.Interior.ColorIndex = xlColorIndexNone Then
cell.Value = ""
Else
cell.Value = 1
End If
Next cell
Fill Colored Cells of a Range
Adjust the values in the constants section.
Sub FillColored()
Const rgAddress As String = "D19:CV68"
Const nStr As String = ""
Const yStr As String = "1"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range: Set rg = ws.Range(rgAddress)
Dim yrg As Range
Dim nrg As Range
Dim cel As Range
For Each cel In rg.Cells
If cel.DisplayFormat.Interior.ColorIndex = xlNone Then
If nrg Is Nothing Then Set nrg = cel Else Set nrg = Union(nrg, cel)
Else
If yrg Is Nothing Then Set yrg = cel Else Set yrg = Union(yrg, cel)
End If
Next cel
If Not nrg Is Nothing Then nrg.Value = nStr
If Not yrg Is Nothing Then yrg.Value = yStr
End Sub
i tried to use range("A1:I1").value to find multiple strings at the first row however it shows that error "mismatch". What have i done wrong here? Is there another way to do it?
Dim sht as worksheet
Set sht = ThisWorkbook.Sheets("Result")
If sht.range("A1:I1").value = " Voltage" and sht.range("A1:I1").value = " Time" ,<---------error 'mismatch' occurs here
call powerandtime
The problem here is that you are comparing an array of values against a single value. In case of such a small array you can make use of some Application.Methods. Another option would be to use Range.Find on the actual Range object. I'll demonstrate both below:
Application.Methods
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Result")
Dim arr As Variant
With Application
arr = .Transpose(ws.Range("A1:I1").Value)
If .Count(.Match(Array("Voltage", "Time"), arr, 0)) = 2 Then
Call PowerAndTime
End If
End With
End Sub
What happens here is that .Match will return an array of two elements. It will either return an error value to the array if either "voltage" or "time" is not found, or it would return a numeric value when either one of them is found. Then .Count will count numeric values within that returned array, and only if the count would be 2, is when both values are present within your initial range.
Note: .Match needs a 1D-array, hence the .Transpose at the start.
Range.Find
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Result")
Dim rng1 As Range, rng2 As Range
Set rng1 = ws.Range("A1:I1").Find("Voltage", lookat:=xlWhole)
Set rng2 = ws.Range("A1:I1").Find("Time", lookat:=xlWhole)
If Not rng1 Is Nothing And Not rng2 Is Nothing Then
Call PowerAndTime
End If
End Sub
So only when both "Voltage" and "Time" are found as xlWhole values within your specific range, it would continue to call PowerAndTime.
Sub testMatchBis()
Dim sh As Worksheet, rng As Range, voltPos As Long, timePos As Long
Dim rngBis As Range, arrBis as Variant
Set sh = ActiveSheet ' use please your sheet here
Set rng = sh.Range("A1:I1")
voltPos = IsMatch(rng, "Voltage")
timePos = IsMatch(rng, "Time")
If voltPos <> 0 And timePos <> 0 Then
Set rngBis = sh.Columns(voltPos)
Set rngBis = Union(rngBis, sh.Columns(timePos))
arrBis = rngBis.Value 'the both columns content will be input in an array
rngBis.Select 'both columns will be selected. Of course, you need to determine
'only part of the comumn keeping values (their last row) and limit the range
'Call call powerandtime 'You must know what this sub must do...
Else
MsgBox "(At least) one of your searched strings could not be found in the range..."
End If
End Sub
Private Function IsMatch(rng As Range, strS As String) As Long
On Error Resume Next
IsMatch = WorksheetFunction.Match(strS, rng, 0)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
IsMatch = 0
End If
On Error GoTo 0
End Function
You could try:
Sub test()
Dim arrStrings As Variant
Dim i As Long, Counter As Long
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:I1")
Counter = 0
arrStrings = Split("Time,Electric", ",")
For i = LBound(arrStrings) To UBound(arrStrings)
If Not rng.Find(arrStrings(i), lookat:=xlWhole) Is Nothing Then
Counter = Counter + 1
GoTo NextIteration
End If
NextIteration:
Next i
If Counter = UBound(arrStrings) + 1 Then
Call PowerAndTime
End If
End Sub
I have to excel sheet and, using vba, I would like to get a value in one of those, search it in the other one and return a correspondant value in the first sheet.
Given the sheet 1:
I would like to search the string I inserted in A5 in another sheet:
Sheet 2:
Once I found the match (A2 in this case), I would get the 'value' (in D2 in this case) and report it in the cell B5 of the Sheet1.
That's what I tried:
Dim rgFound As Range
Dim defVal As Range
Dim currParam As Range
Dim currParamDict As Range
For Each defVal In Range("B:B")
Set currParam = Cells(Range(defVal).Row, Range(defVal).Column - 1)
If currParam Is Nothing Then
Debug.Print "Name was not found."
End If
Set rgFound = Worksheets("Sheet2").Range("A:A").Find(currParam.value)
If rgFound Is Nothing Then
Debug.Print "Name was not found."
Else
Set currParamDict = Cells(Range(rgFound).Row, Range(rgFound).Column + 3)
defVal.value = currParamDict.value
End If
Next defVal
That's clearly wrong since the compiler gives me an error on Range at the line:
Set currParam = Cells(Range(defVal).Row, Range(defVal).Column - 1)
Try this
Sub x()
Dim rgFound As Range
Dim defVal As Range
Dim currParam As Range
Dim currParamDict As Range
With Worksheets("Sheet1")
For Each defVal In .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Offset(, 1)
Set currParam = defVal.Offset(, -1)
If Len(currParam.Value) > 0 Then
Set rgFound = Worksheets("Sheet2").Range("A:A").Find(currParam.Value)
If rgFound Is Nothing Then
Debug.Print "Name was not found."
Else
Set currParamDict = rgFound.Offset(, 3)
defVal.Value = currParamDict.Value
End If
End If
Next defVal
End With
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