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
Related
So every cell that has a value of 0, that row will be hidden. And any value that is outside the minimum and maximum values will be red.
How to identify red color but active (not hidden) with macro? because I used "range. displayformat. interior. color = vbred", the cells are red but hidden are also counted. Thanks.
Try this, the visible cells will be formatted
Set rng = Range("Your range").SpecialCells(xlCellTypeVisible)
rng = ActiveCell.DisplayFormat.Interior.Color = vbRed
Here is the sample code for the "if" condition that you ask for.
Sub Highlight_Greater_Than()
Dim ws As Worksheet
Dim Rng As Range
Dim ColorCell As Range
Set ws = Worksheets("Name")
Set rng = Range("Your range").SpecialCells(xlCellTypeVisible)
'rng = ActiveCell.DisplayFormat.Interior.Color = vbRed
Set ColorCell = rng
For Each ColorCell In Rng
If ColorCell.Value > 1 Then " You can define here" "greater, smaller, equal etc.."
ColorCell.Interior.Color = vbred
Else
ColorCell.Interior.ColorIndex = "vb(colour)or" xlNone
End If
Next
End Sub
I'm trying to find a solution for macro described below in steps - it should copy data from range in one file and then paste it in other file in same range as original data:
Find coloured cells in sheet, select them and copy
Go to other file to sheet named same as source sheet
Paste data in same ranges as in source file (e.g. if data was copied from range A4:B20, A22:B24 and E4:G20 [selection will always contain union of ranges like this] I want to use same ranges in destination to paste data)
In below code I get error "Application-defined or object-defined error" and part of code "With ActiveSheet.Range(SelectedRng)" highlighted in yellow.
Could you please help me find a solution for this?
Sub SelectCellsWithColorIndex()
Const rgAddress As String = "A1:AZ300"
Const cIndex As Long = 37
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range(rgAddress)
Dim sh_name As String
Dim crg As Range
Dim cell As Range
Dim SelectedRng As Range
Application.ScreenUpdating = False
For Each cell In rg.Cells
If cell.Interior.ColorIndex = cIndex Then
If crg Is Nothing Then
Set crg = cell
Else
Set crg = Union(crg, cell)
End If
End If
Next cell
If crg Is Nothing Then
MsgBox "No coloured cells in range.", vbExclamation
Else
crg.Select
End If
Set SelectedRng = ActiveSheet.Range(Selection.Address)
SelectedRng.Copy
sh_name = ActiveSheet.Name
Workbooks("Workbook2.xlsx").Activate
Worksheets(sh_name).Activate
With ActiveSheet.Range(SelectedRng)
.PasteSpecial xlPasteValues
End With
Application.ScreenUpdating = True
End Sub
Please, try the next way. It uses Find with SearchFormat parameter and should be much faster than iteration between each cell in the range. Then, a discontinuous (Union) range cannot be copied at once. In order to also be fast, an iteration between the discontinuous range areas are necessary and clipboard should not be used. Selecting, activating only consumes Excel resources, not bringing any benefit, too:
Sub SelectCellsWithColorIndex()
Const rgAddress As String = "A1:AZ300"
Const cIndex As Long = 37
Dim ws As Worksheet: Set ws = ActiveSheet
Dim ws2 As Worksheet: Set ws2 = Workbooks("Workbook2.xlsx").Worksheets(ws.name) 'it must exist!
Dim rg As Range: Set rg = ws.Range(rgAddress)
Dim crg As Range, blueCell As Range, firstAddress As String, A As Range
'Sets or returns the search criteria for the type of cell formats to find:
With Application.FindFormat
.Clear
.Interior.ColorIndex = cIndex
.Locked = True
End With
Set blueCell = rg.Find(what:=vbNullString, SearchFormat:=True)
If Not blueCell Is Nothing Then
firstAddress = blueCell.Address
Do
If crg Is Nothing Then Set crg = blueCell Else Set crg = Union(crg, blueCell)
Set blueCell = rg.Find(what:=vbNullString, After:=blueCell, SearchFormat:=True)
Loop While blueCell.Address <> firstAddress
Else
MsgBox "no cell with (that) blue color found", vbInformation, "No blue cells...": Exit Sub
End If
For Each A In crg.Areas
ws2.Range(A.Address).Value = A.Value
Next A
End Sub
Please, send some feedback after testing it.
Is the Union range is huge, Application.ScreenUpdating = False and Application.Calculation = xlCalculationManual at the beginning of copying loop followed by Application.ScreenUpdating = True and Application.Calculation = xlCalculationAutomatic after, will help a litle. Otherwise, for a reasonable number of cells it will be fast enough without any optimization...
I am trying to figure out simple code to make picture objects visible if particular cells contain data. Cells in range R12:R61 contains objects (pictures, ie. Round Rectangles) that are not visible (.visible = false).
If some cells in range P12:P61 contains data then corresponding hidden image in range R12:R61 of that row need to be visible. I've tried something like this:
Dim xPicRg As Range
Dim xPic As Picture
Dim xRg As Range
Set xRg = Range("R12:R61")
For Each xPic In ActiveSheet.Pictures
Set xPicRg = Range(xPic.TopLeftCell.Address & ":" & xPic.BottomRightCell.Address)
If Not Intersect(xRg, xPicRg) Is Nothing Then xPic.Visible = True
Next
I'm stuck with this one.
Let's imagine our input looking like this:
Then, working with Range("A1:B10"), the only picture that should be present is the one in rows 1 and 2, as for the other 3 there are numbers in column "A":
Sub TestMe()
Dim checkRange As Range
Dim myPic As Picture
With ActiveSheet
Set checkRange = .Range("A1:B10")
Dim myRow As Range
For Each myRow In checkRange.Rows
If WorksheetFunction.Count(myRow.Cells) > 0 Then
For Each myPic In .Pictures
Debug.Print myPic.TopLeftCell.Address
Debug.Print myPic.BottomRightCell.Address
Dim picRange As Range
Set picRange = .Range(.Cells(myPic.TopLeftCell.Row, myPic.TopLeftCell.Column), _
.Cells(myPic.BottomRightCell.Row, myPic.BottomRightCell.Column))
Debug.Print picRange.Address
If Not Intersect(picRange, myRow) Is Nothing Then
myPic.Visible = False
End If
Next
End If
Next
End With
End Sub
I managed to get this code:
Sub ColorChange()
Dim ws As Worksheet
Set ws = Worksheets(2)
clrOrange = 39423
clrWhite = RGB(255, 255, 255)
If ws.Range("D19").Value = "1" And ws.Range("E19").Value = "1" Then
ws.Range("D19", "E19").Interior.Color = clrOrange
ElseIf ws.Range("D19").Value = "0" Or ws.Range("E19").Value = "0" Then
ws.Range("D19", "E19").Interior.Color = clrWhite
End If
End Sub
This works, but now I need this code to work in 50 rows and 314 cells, but every time only on two cells so, D19+E19, D20+E20, etc. Endpoint is DB314+DC314.
Is there a way, without needing to copy paste this code and replacing all the row and cells by hand?
It also would be nice that if the value in the two cells is anything other than 1+1 the cell color changes back to white.
EDIT: The solution thanks to #VBasic2008.
I added the following to the sheet's code to get the solution to work automatically:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D19:DC314")) Is Nothing Then
Call ColorChange
End If
End Sub
And because Interior.Color removes borders I added the following sub:
Sub vba_borders()
Dim iRange As Range
Dim iCells As Range
Set iRange = Range("D19:DC67,D70:DC86,D89:DC124,D127:DC176,D179:DC212,D215:DC252,D255:DC291,D294:DC314")
For Each iCells In iRange
iCells.BorderAround _
LineStyle:=xlContinuous, _
Weight:=xlThin
Next iCells
End Sub
The Range is a bit different to exclude some rows.
Compare Values in the Two Cells of Column Pairs
Option Explicit
Sub ColorChange()
Const rgAddress As String = "D19:DC314"
Const Orange As Long = 39423
Const White As Long = 16777215
Dim wb As Workbook ' (Source) Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
Dim rg As Range ' (Source) Range
Set rg = wb.Worksheets(2).Range(rgAddress) ' Rather use tab name ("Sheet2").
Dim cCount As Long ' Columns Count
cCount = rg.Columns.Count
Dim brg As Range ' Built Range
Dim rrg As Range ' Row Range
Dim crg As Range ' Two-Cell Range
Dim j As Long ' (Source)/Row Range Columns Counter
For Each rrg In rg.Rows
For j = 2 To cCount Step 2
Set crg = rrg.Cells(j - 1).Resize(, 2)
If crg.Cells(1).Value = 1 And crg.Cells(2).Value = 1 Then
If brg Is Nothing Then
Set brg = crg
Else
Set brg = Union(brg, crg)
End If
End If
Next j
Next rrg
Application.ScreenUpdating = False
rg.Interior.Color = White
If Not brg Is Nothing Then
brg.Interior.Color = Orange
End If
Application.ScreenUpdating = True
End Sub
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