How can I set a rules to turn the row backround Yellow and also apply a pattern to some specific columns of this same row, only using VBA ?
Sub FormatRange()
Dim MyRange As Range, listSep As String
Set MyRange = Range("MyBoard")
listSep = Application.International(xlListSeparator)
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add Type:=xlExpression, formula1:="=ISNUMBER(SEARCH(" & _
"""Customer""" & listSep & MyRange.cells(1, 1).Address(0, 1) & "))"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
MyRange.FormatConditions(1).Interior.Pattern = xlGray75
End Sub
Can I just specify the column letter at the same time as the Range ? (column B/C/E/H)
Please, test the next adapted code. It assumes that you need, **for the same Formula2 condition (formula), to place a specific pattern only on the mention columns (of the named range):
Private Sub FormatRange()
Dim MyRange As Range, listSep As String
Set MyRange = Range("MyBoard")
listSep = Application.International(xlListSeparator)
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add Type:=xlExpression, formula1:="=ISNUMBER(SEARCH(" & _
"""Customer""" & listSep & MyRange.cells(1, 1).Address(0, 1) & "))"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
'the code new part:
Dim myRng As Range
Set myRng = Intersect(MyRange, MyRange.Parent.Range("B:C, E:E, H:H"))
myRng.FormatConditions.Delete
myRng.FormatConditions.Add Type:=xlExpression, formula1:="=ISNUMBER(SEARCH(" & _
"""Customer""" & listSep & MyRange.cells(1, 1).Address(0, 1) & "))"
myRng.FormatConditions(1).Interior.Pattern = xlGray75
End Sub
Related
I'm trying to apply some conditionals rules using VBA in a Range.
But I'm very new with conditional formating VBA so I'm a bit lost.
My Users can add rows above of the target range, that mean the range address could be always different.
let's admit that for the exemple, my range is Worksheets("test").Range("MyBoard")
("MyBoard" is my range name, currently located at A19:O32)
How can I apply a rule to turn yellow each rows of my range if the first column contains the value "Customer" ?
Sub FormatRange()
Dim MyRange As Range
Set MyRange = Worksheets("test").Range("MyBoard")
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add Type:=xlCellValue, Formula1:="=COUNTIF(MyRange;"*Customer*") > 0"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
End Sub
Thanks for the help
Please, use the next adapted code:
Sub FormatRange()
Dim MyRange As Range, listSep As String
Set MyRange = Range("MyBoard")
listSep = Application.International(xlListSeparator)
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add Type:=xlExpression, formula1:="=ISNUMBER(SEARCH(" & _
"""Customer""" & listSep & MyRange.cells(1, 1).Address(0, 1) & "))"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
End Sub
Conditional formatting has some very particular format to get an entire row to work.
E.g., If i want to apply a color to each row, between certain columns of a specified range:
With .Range(.Cells(1, startColumn), .Cells(lastRow, endColumn))
.FormatConditions.Add Type:=xlExpression, Formula1:="=$A1>1"
.FormatConditions(1).Font.Italic = True
End With
Edit1: Indicating use of Find() for the row containing "Customer" being used for the above code.
Sub test()
With Sheets(1)
Dim customerCell As Range: Set customerCell = .Columns(1).Find("Customer")
If customerCell Is Nothing Then Exit Sub
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells.FormatConditions.Delete
With .Range(.Cells(customerCell.Row, 1), .Cells(lastRow, 10))
.FormatConditions.Add Type:=xlExpression, Formula1:="=CountIf($A" & customerCell.Row & ",""*Customer*"")"
.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
End With
End With
End Sub
I think, this is what your are looking for:
Sub FormatRange()
Dim MyRange As Range
Set MyRange = Worksheets("test").Range("MyBoard")
Dim startAddress As String
startAddress = MyRange.Cells(1, 1).Address(False, True) ' will return e.g. $A19 in your case
Dim formula As String
'formula = startAddress & " = ""customer""" 'exact customer
formula = "ISNUMBER(FIND(""customer""," & startAddress & "))" ' *customer*
Dim fc As FormatCondition
With MyRange
.FormatConditions.Delete
Set fc = .FormatConditions.Add(xlExpression, Formula1:="=" & formula)
fc.Interior.Color = RGB(255, 255, 0)
End With
End Sub
You have to reference the first cell within your range - and "fix" the column --> .Address(False, True) will return $A19 in your case.
Then you need to build a valid string for the formula to pass to the format condition
You need double quotes for "customer" when building the string.
I'm currently trying to develop my first conditional formatting on VBA, but after hours of trial it still doesn't work.
I'm aiming for a formula that would change the background / highlight the text of a cell that contains something else than any alphabet letters (not sensitive to caps or not). Accents, numbers and special characters would be the trigger
Here is my current code
Thank you in advance for your help
Sub Highlight()
Dim MyRange As Range
Set MyRange = Selection
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add xlExpression, , Formula1:="=IsAlpha()=false"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 0, 0)
End Sub
And IsAlpha would be a function like
Function IsAlpha(s) As Boolean
IsAlpha = Len(s) And Not s Like "*[!a-zA-Z ]*"
End Function
You need to pass an argument to IsAlpha. Try the following:
Sub Highlight()
Dim MyRange As Range
Set MyRange = Selection
MyRange.FormatConditions.Delete
Dim s As String
s = "=NOT(IsAlpha(" & MyRange.Cells(1).Address(False, False) & "))"
MyRange.FormatConditions.Add xlExpression, Formula1:=s
MyRange.FormatConditions(1).Interior.Color = vbRed 'Or use RGB...
End Sub
In action:
Highlight Not Pure Alpha
There is a delay of about 2s before the cells get colored (on my machine). I wonder if a worksheet change would handle this smoother (if the range contains values (not formulas)).
Option Explicit
Sub HighlightNotPureAlphaTEST()
If TypeOf Selection Is Range Then
HighlightNotPureAlpha Selection
End If
End Sub
Sub HighlightNotPureAlpha(ByVal rg As Range)
With rg
.FormatConditions.Delete
' To not highlight blanks...
.FormatConditions.Add xlExpression, , _
"=NOT(IsAlphaOrBlank(" & .Cells(1).Address(0, 0) & "))"
' To highlight blanks:
'.FormatConditions.Add xlExpression, , _
"=NOT(IsAlpha(" & .Cells(1).Address(0, 0) & "))"
.FormatConditions(1).Interior.Color = RGB(255, 0, 0)
End With
End Sub
Function IsAlphaOrBlank(ByVal S As String) As Boolean
Application.Volatile
IsAlphaOrBlank = Not S Like "*[!A-Za-z]*"
End Function
Function IsAlpha(ByVal S As String) As Boolean
Application.Volatile
If Len(S) > 0 Then IsAlpha = Not S Like "*[!A-Za-z]*"
End Function
I have code that is not writing anything. I get a Match problem and a mismatch error in the code line below
rtar = Evaluate("=MATCH(" & ColLetter(rng1.Columns(2).Column) & rng1.Row & "&" & ColLetter(rng1.Columns(3).Column) & rng1.Row & "," & ColLetter(rng3.Columns(1).Column) & "1:" & ColLetter(rng3.Columns(1).Column) & last2 & "&" & ColLetter(rng3.Columns(3).Column) & "1:" & ColLetter(rng3.Columns(3).Column) & last2 & ",0)")
is highlighted in yellow.
To quickly explain the code and using my Excel image below the expected written result is the grey highlight in cells F8,G8,H8. The data that gets written into these cells only occurs when any set of numbers get written in the cell range, E6:E17 and only then. The data source is from cells M5 to O17. So as an example when cell E8 (3rd line down) has the 10-1 in it the code would search the data source (3rd line down) and write from the data source cells M8/N8/O8 to cells F8/G8/H8.
Please don’t suggest using a formula because in the arr1 and arr2 I will be using about 50 or more ranges. I only want to use this code and just need help with making the necessary offset and match adjustments.
Sub PlaceNumbers()
Dim c As Range, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range
Dim last1 As Long, last2 As Long, rtar As Long, xtar As Long
Application.ScreenUpdating = False
With ActiveSheet
'create arrays
arr1 = Array(.Range("D5:H17"))
arr2 = Array(.Range("L5:O17)) '
'loop through arrays
For i = LBound(arr1) To UBound(arr1)
Set rng1 = arr1(i)
Set rng3 = arr2(i)
last1 = .Cells(.Rows.Count, ColLetter(rng1.Columns(1).Column)).End(xlUp).Row
last2 = .Cells(.Rows.Count, ColLetter(rng3.Columns(1).Column)).End(xlUp).Row
For Each c In rng1.Offset(1, 1).Resize(, 1)
If c <> "" Then
rtar = Evaluate("=MATCH(" & ColLetter(rng1.Columns(2).Column) & rng1.Row & "&" & ColLetter(rng1.Columns(3).Column) & rng1.Row & "," & ColLetter(rng3.Columns(1).Column) & "1:" & ColLetter(rng3.Columns(1).Column) & last2 & "&" & ColLetter(rng3.Columns(3).Column) & "1:" & ColLetter(rng3.Columns(3).Column) & last2 & ",0)")
xtar = Application.Match(c.Offset(0, -2), Range(ColLetter(rng3.Columns(1).Column) & rtar & ":" & ColLetter(rng3.Columns(1).Column) & last2), 0)
With Application.WorksheetFunction
c.Offset(0, 1) = .Index(Range(ColLetter(rng3.Columns(2).Column) & rtar & ":" & ColLetter(rng3.Columns(2).Column) & last2), xtar)
c.Offset(0, 2) = .Index(Range(ColLetter(rng3.Columns(3).Column) & rtar & ":" & ColLetter(rng3.Columns(3).Column) & last2), xtar)
c.Offset(0, 3) = .Index(Range(ColLetter(rng3.Columns(4).Column) & rtar & ":" & ColLetter(rng3.Columns(4).Column) & last2), xtar)
End With
End If
Next c
Next
End With
Application.ScreenUpdating = True
End Sub
Function ColLetter(Collet As Integer) As String
ColLetter = Split(Cells(1, Collet).Address, "$")(1)
End Function
Exec image
I think the existing answer (https://stackoverflow.com/a/55959955/8811778) is better (provided it does what you need it to) as it's shorter and easier to maintain/debug.
But I include an alternative, longer version below.
If the only logic/rule that results in values in M8:O8 being written to F8:H8 is "number of rows down" (i.e. 3 rows down), then I don't think you really need to use MATCH function.
If I understand correctly, you just want the Nth row of the source data, where N corresponds to the row of whatever non-empty cell (in the yellow cells) you're currently processing.
If you change your For each c in rng1.Offset(1, 1).Resize(, 1) to instead loop through the yellow cells one row at a time, you will have access to N (otherwise you need to do some row arithmetic: c.Row - first row of yellow cells + etc...).
Note that N is the variable rowIndexRelativeToRange in the code below and is relative to the range, not the worksheet (i.e. first row in the yellow cells, not first row of the worksheet).
Option Explicit
Sub PlaceNumbers()
Dim someSheet As Worksheet
Set someSheet = ActiveSheet ' Refer to this sheet by name if possible
With someSheet
Dim arr1 As Variant
arr1 = Array(.Range("D5:H17"))
Dim arr2 As Variant
arr2 = Array(.Range("L5:O17"))
End With
'Application.ScreenUpdating = False ' Uncomment when you think code is ready/working
Dim i As Long
Dim rng1 As Range, rng2 As Range
For i = LBound(arr1) To UBound(arr1)
Set rng1 = arr1(i)
Set rng2 = arr2(i)
' We have to resize the ranges (to get rid of the first row and first column)
' You may want to re-think whether the addresses you specify (when creating arr1 and arr2)
' even need to include the first row and first column (e.g. E6:H17 instead of D5:H17)
' -- or whether you could just ensure the address passed in already excludes the first row and first column.
' It depends on whether you need to use the first row and first column (somewhere else in your code).
' But precluding them (if possible) would shorten/simplify the procedure's logic.
Dim inputColumn As Range
Set inputColumn = rng1.Offset(1, 1).Resize(rng1.Rows.Count - 1, 1) ' -1 when resizing, otherwise you're looking at range E6:E18, not E6:E17
Dim dataSourceRange As Range
Set dataSourceRange = rng2.Offset(1, 1).Resize(rng2.Rows.Count - 1, rng2.Columns.Count - 1)
Dim rowIndexRelativeToRange As Long ' This index is 1-based and relative to the range, not the worksheet.
For rowIndexRelativeToRange = 1 To inputColumn.Rows.Count
If inputColumn(rowIndexRelativeToRange, 1) <> "" Then
inputColumn(rowIndexRelativeToRange, 1).Offset(0, 1).Resize(, 3).Value = dataSourceRange(rowIndexRelativeToRange, 1).Resize(, 3).Value
End If
Next rowIndexRelativeToRange
Next i
'Application.ScreenUpdating = True ' Uncomment when you think code is ready/working
End Sub
Putting this here because I don't want to put in a comment. Why can't you use a worksheet change event? You can set the target range to multiple ranges. Place this code in the worksheet containing the two areas you showed in your example. When the value in a cell changes it will automatically update the three cells to the right.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E6:E17")) Is Nothing Then
Range(Target.Address).Offset(, 1).Resize(1, 3).Value = Range(Target.Address).Offset(, 8).Resize(1, 3).Value
End If
End Sub
I'm finding the matches in two columns (myrange1 & myrange2), filling them in a third column ("R") of sheet2. I have my Range from column "R" printing out to a PDF just fine, but I want each one to be numbered sequentially on the PDF i.e. 1,2,3,4 etc. Help much appreciated. Pretty new to VBA as well.
Sub matchcopy()
Dim myrange1 As Range, myrange2 As Range, cell As Range
With Sheets("Sheet1")
Set myrange1 = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
End With
With Sheets("Sheet2")
Set myrange2 = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
End With
For Each cell In myrange1
If Not IsError(Application.Match(cell.Value, myrange2, 0)) Then
'cell.Value, myrange2, 0
cell.Copy
Sheet2.Range("R5000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
Else
'MsgBox "no match is found in range"
End If
Next cell
Columns("R:R").EntireColumn.AutoFit
Call Set_PrintRnag
End Sub
Sub Set_PrintRnag()
Dim LstRw As Long
Dim Rng As Range
LstRw = Cells(Rows.Count, "R").End(xlUp).Row
Set Rng = Range("R1:R" & LstRw)
With ActiveSheet.PageSetup
.LeftHeader = "&C &B &20 Cohort List Report : " & Format(Date,
"mm/dd/yyyy")
End With
Rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & _
"\CohortList " & " " & Format(Date, "mm-dd-yyyy") & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
As close as possible to your code, though looping through a range is always time consuming and you would be faster working with arrays of the columns to be compared:
Option Explicit
Sub matchcopy()
Dim i&
Dim myrange1 As Range, myrange2 As Range, cell As Range
' You can use the Codenames instead of Worksheet("Sheet1") etc.
Set myrange1 = Sheet1.Range("A1", Sheet1.Range("A" & Rows.Count).End(xlUp))
Set myrange2 = Sheet2.Range("A1", Sheet2.Range("A" & Rows.Count).End(xlUp))
Sheet2.Range("R:S") = "" ' <~~ clear result columns
For Each cell In myrange1 ' presumably unique items
If Not IsError(Application.Match(cell.Value, myrange2, 0)) Then
cell.Copy
With Sheet2.Range("R5000").End(xlUp)
i = i + 1 ' <~~ counter
.Offset(1, 0) = i ' counter i equals .Row - 1
.Offset(1, 1).PasteSpecial xlPasteFormulasAndNumberFormats
End With
Else
'MsgBox "no match is found in range"
End If
Next cell
Sheet2.Columns("R:S").EntireColumn.AutoFit
Call Set_PrintRnag ' called procedure see OP
End Sub
Sub Set_PrintRnag()
Dim LstRw As Long
Dim Rng As Range
LstRw = Sheet2.Cells(Rows.Count, "R").End(xlUp).Row
Set Rng = Sheet2.Range("R1:S" & LstRw)
With Sheet2.PageSetup
.LeftHeader = "&C &B &20 Cohort List Report : " & Format(Date, "mm/dd/yyyy")
End With
Rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & _
"\CohortList " & " " & Format(Date, "mm-dd-yyyy") & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub
Additional hint
To get some ideas how to use a datafield array, see e.g. SO answer to Loop with multiple ranges
Do you need a VBA script to accomplish your desired goal? If you are just trying to compare two values and output the result in your Column R, you should be able to do it with an IF function: https://support.office.com/en-us/article/if-function-69aed7c9-4e8a-4755-a9bc-aa8bbff73be2
If you want sequential numbering for results, I'd suggest having the number in an adjacent column and exploring the COUNTA function: https://support.office.com/en-us/article/counta-function-7dc98875-d5c1-46f1-9a82-53f3219e2509
And if you do require this in VBA scripting format, you can do it with an Excel function first and record a macro afterwards. Makes creating the actual VBA syntax a little easier! https://support.office.com/en-us/article/automate-tasks-with-the-macro-recorder-974ef220-f716-4e01-b015-3ea70e64937b
My macro currently works by pressing CTRL+F to open the search box which searches either REF1 or REF2. If the information is found, it copies over to the next cell basically to show it's there. If the information is not found, it pastes the data searched for in cell L4 so a label can be printed.
What I'm trying to do:
Remove the CTRL+F and basically run from a cell (let's say cell L18). However, when scanned the scanner basically types in the numbers then presses enter/return.
I was wondering, would it be possible to make it run like this.
Select cell L18 then keep scanning until either:
A) The list is done - nothing is missing
B) If REF1/REF2 doesn't match, pastes that data into cell L4 for a label to be printing.
(Current version using CTRL+F): http://oi39.tinypic.com/mima9x.jpg
(Example of what I need): http://oi42.tinypic.com/24fiwt1.jpg
Current macro:
Sub Extra_Missing_Item() Application.ScreenUpdating = False
Dim rangeToSearch As Range
With Sheets(1)
Set rangeToSearch = .Range("A2:B" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Dim searchAmount As String
searchAmount = InputBox("Scan the REF1 or REF2:")
Dim cell As Range
Set cell = rangeToSearch.Find(searchAmount, LookIn:=xlValues)
With Sheets(1)
If Not cell Is Nothing Then
.Range("E" & cell.Row & ":G" & cell.Row).Value = _
.Range("A" & cell.Row & ":C" & cell.Row).Value
Else
MsgBox "REF1/REF2: " & searchAmount & " shouldn't be here"
.Range("L4").Value = searchAmount
Range("L9").Select
End If
End With
Application.ScreenUpdating = True
End Sub
I think I understand what you need. This macro calls each time any cell on the sheet changed (but if changed cell is not L18, macro do nothing):
Private Sub Worksheet_Change(ByVal Target As Range)
If Application.Intersect(Target, Range("L18")) Is Nothing Then
Exit Sub
End If
Dim rangeToSearch As Range
Dim searchAmount As String
Dim cell As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set rangeToSearch = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row)
searchAmount = Target.value
Set cell = rangeToSearch.Find(searchAmount, LookIn:=xlValues)
If Not cell Is Nothing Then
Range("E" & cell.Row & ":G" & cell.Row).value = _
Range("A" & cell.Row & ":C" & cell.Row).value
Else
MsgBox "REF1/REF2: " & searchAmount & " shouldn't be here"
Range("L4").value = searchAmount
End If
Range("L18").Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Put this macro in the Sheet module (coresponding to the sheet where your data is):