I am looking to highlight certain cells in a spreadsheet when a value is entered in a different column. I realize this can be done with conditional formatting but, due to circumstances within the company, I must use VBA. (The spreadsheet is passed onto another program that can't read conditional formatting)
I am trying to highlight 11 different columns within my range of values whenever ANYTHING is entered into column L. For example, when a date it entered in L2, then C2, J2, K2, etc. are highlighted yellow.
Below is what I have come up with.. unfortunately, when I run the macro, nothing happens. I see it run, but I get no results - not even an error message. Thanks in advance for the time you take to help me out!
Dim rng As Range, r As Range
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("From GIS")
Set sht2 = wb.Sheets("To MapCall")
Set rng = Intersect(sht2.UsedRange, Range("L:L")).Cells
For Each r In rng
If r.Value = "" Then
Cells(r.Row + 1, "C,J,K,Q,AI,AV,AW,AX,AY,AZ,BR").Interior.Color = RGB(255, 255, 0)
End If
Next r
Please give this a try and change r.Value = "" to r.Value <> "" as you want to apply a color if something is entered in the range not when it is blank. Tweak it as per what you actually need. I am also not sure why have you used r.Row + 1? It that's not what you want, replace i = r.Row + 1 in the below code with i = r.Row.
Also it's a good practice to declare all the variables used in the code.
Dim wb As Workbook
Dim sht1 As Worksheet, sht2 As Worksheet
Dim rng As Range, r As Range, clrRng As Range
Dim i As Long
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("From GIS")
Set sht2 = wb.Sheets("To MapCall")
Set rng = Intersect(sht2.UsedRange, Range("L:L")).Cells
For Each r In rng
If r.Value = "" Then
i = r.Row + 1
Set clrRng = Union(Range("C" & i), Range("J" & i & ":K" & i), Range("Q" & i), Range("AI" & i), Range("AV" & i & ":AZ" & i), Range("BR" & i))
clrRng.Interior.Color = RGB(255, 255, 0)
End If
Next r
One method would be to create a union of ranges.
Sub test()
Dim Rng As Range, r As Range, uRng As Range, row As Long
Set wb = ThisWorkbook
Set sht1 = wb.Sheets("From GIS")
Set sht2 = wb.Sheets("To MapCall")
Set Rng = Intersect(sht2.UsedRange, Range("L:L")).Cells
For Each r In Rng
If r.Value <> "" Then
row = r.row
Set uRng = Union(Cells(row, "C"), Cells(row, "J")) 'Etc... Keep going with each column
uRng.Interior.Color = RGB(255, 255, 0)
End If
Next r
End Sub
Related
Trying to figure out what the code below is doing, but cannot figure it out:
For Each c In Sheets("Control").Range("y3:y" & Range("y" &
Rows.Count).End(xlUp).Row).Cells
Sheets("forecast").Range("a5") = c
What I think is happening:
Below c is set to a certain cell, this contains a name. In the upper part for every cell, in sheet control, for the range from y3 till the end, .... and then the confusion starts. What happens next:
Range(".." & Range(".." & Rows.Count).End(x1Up).Row).Cells
How do I read this?
This is the table from Sheets("Control"):
Range(".." & Rows.Count).End(x1Up).Row - you have a typo here, it is xlUp (l, for lemonade, instead of 1). Use Option Explicit to avoid such mistakes!
Anyhow, it means something like that: in column "..", in your case y, go to the very last row at the bottom. Then go up, until first non-blank cell is met and get its Row.
So if you have values in range Y1:Y20, then going up from the bottom will end in 20th row, giving you 20 as the row number.
There are two ways. You can do this by importing it as a range object or by saving it as an array.
First: as Range
Sub test()
Dim Ws As Worksheet
Dim rngDB As Range, c As Range
Set Ws = Sheets("Control")
With Ws
Set rngDB = .Range("y3", "y" & .Range("y" & Rows.Count).End(xlUp).Row)
End With
For Each c In rngDB
Sheets("forecast").Range("a5") = c
Sheets("forecast").Range("b5") = c.Offset(0, 1)
End Sub
Second: as Variant Array
Sub test2()
Dim Ws As Worksheet
Dim rngDB As Range, c As Range
Dim vDB
Dim i As Long
Set Ws = Sheets("Control")
With Ws
Set rngDB = .Range("y3", "z" & .Range("y" & Rows.Count).End(xlUp).Row)
vDB = rngDB '<~~ get data from rngdb to array vDB
End With
For i = 1 To UBound(vDB, 1)
Sheets("forecast").Range("a" & i + 4) = vDB(i, 1)
Sheets("forecast").Range("b" & i + 4) = vDB(i, 2)
End Sub
I am not getting dynamic range work sheet name in formula. Can anyone assist on this? I get the active sheet range in the formula as =COUNTIF(I3:I31,A3)
Sub Test_DaySumm()
Dim Rg As Range
wksMain.Select
Dim ws1 As Worksheet
Set ws1 = wksMain
If ws1.FilterMode = True Then ws1.ShowAllData
LastRow = ws1.Cells(Rows.Count, "I").End(xlUp).Row
Set MyRange = ws1.Range(Cells(3, 9), Cells(LastRow, 9))
wksDaySummary.Select
xRow = 3
Do Until wksDaySummary.Cells(xRow, 1) = ""
Set Rg = wksDaySummary.Cells(xRow, 2)
Rg.Formula = "=COUNTIF( " & MyRange.Address(0, 0) & "," & Rg.Offset(0, -1).Address(0, 0) & ")"
Rg.Value = Rg.Value
xRow = xRow + 1
DoEvents
Loop
End Sub
Have a look at the Range.Address Property documentary
.Address(RowAbsolute, ColumnAbsolute, ReferenceStyle, External, RelativeTo)
and use the External:=True parameter get get the worksheet name in the address too:
MyRange.Address(RowAbsolute:=False, ColumnAbsolute:=False, External:=True)
So instead of eg I3:I31 the result would be like 'Main Sheet'!I3:I31
I want to screen all sheets for values that starts with "D"
In the sheets I formed blocks (1 column, 4 rows) with
- owner
- area
- parcel (that is allways starting with a "D")
- year of transaction (blocks of 1 column and 4 rows).
I want to make a summary in sheet "Test".
I'm able to find the parcel, but how can I get the info from the cell above?
Sub Zoek_kavels()
Dim ws As Worksheet
Dim rng As Range
Dim Area
Dim Kavel As String
rij = 1
For Each ws In ActiveWorkbook.Sheets
Set rng = ws.UsedRange
For Each cell In rng
If Left(cell.Value, 1) = "D" Then 'Starts with D
Sheets("Test").Cells(rij, 1) = cell.Value 'Kavel D..
Cells(cell.row - 1, cell.Column).Select
Area = ActiveCell.Value
Sheets("Test").Cells(rij, 2) = Area 'Oppervlakte
Sheets("Test").Cells(rij, 3) = ws.Name 'Werkblad naam
rij = rij + 1
End If
Next
Next
End Sub
A nice simple loop should do the trick, you may have had spaces in the worksheet, that would throw off the used range.
Here is a different approach.
Sub Get_CellAboveD()
Dim LstRw As Long, sh As Worksheet, rng As Range, c As Range, ws As Worksheet, r As Long
Set ws = Sheets("Test")
For Each sh In Sheets
If sh.Name <> ws.Name Then
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:A" & LstRw)
If LstRw > 1 Then
For Each c In rng.Cells
If Left(c, 1) = "D" Then
r = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
ws.Range("A" & r).Value = c
ws.Range("B" & r).Value = c.Offset(-1).Value
ws.Range("C" & r).Value = sh.Name
End If
Next c
End If
End With
End If
Next sh
End Sub
There are two important points (and two not so important) to take care of your code:
start from row 2, because you are using .row - 1. Thus, if you start at row 1, row-1 would throw an error;
try to avoid Select, ActiveCell, etc.;(How to avoid using Select in Excel VBA);
write comments in English, not in Dutch (also good idea for variable names as well, rij or kavel do not help a lot);
declare the type of your variables, e.g. dim Area as String or as Long or anything else;
Option Explicit
Sub ZoekKavels()
Dim ws As Worksheet
Dim rng As Range
Dim Kavel As String
Dim rij As Long
Dim cell As Range
rij = 2 'start from the second row to avoid errors in .Row-1
For Each ws In ActiveWorkbook.Worksheets
Set rng = ws.UsedRange
For Each cell In rng
If Left(cell, 1) = "D" Then
With Worksheets("Test")
.Cells(rij, 1) = cell
.Cells(rij, 2) = ws.Cells(cell.Row - 1, cell.Column)
.Cells(rij, 3) = ws.Name
End With
rij = rij + 1
End If
Next
Next
End Sub
Or you can use .Cells(rij, 2) = cell.Offset(-1, 0) instead of Cells(cell.Row - 1, cell.Column), as proposed in the comments by #Shai Rado.
I have written a macro to remove rows containing certain text in it. If either of the keyword contains any text, the macro will delete the row. However, the macro doesn't work at all. Perhaps, i did something wrong in it. Hope somebody will help me rectify this. Thanks in advance.
Here is what I'm trying with:
Sub customized_row_removal()
Dim i As Long
i = 2
Do Until Cells(i, 1).Value = ""
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Cells(i, 1).Select
Selection.EntireRow.Delete
End If
i = i + 1
Loop
End Sub
The keyword within the text I was searching in to delete:
AIRLINE DRIVE OWNER mth
A rtd REPAIRS INC
AANA MICHAEL B ET AL
ABASS OLADOKUN
ABBOTT npt P
AIRLINE AANA MTH
ABASS REPAIRS NPT
Try like this.
What about Using Lcase.
Sub customized_row_removal()
Dim rngDB As Range, rngU As Range, rng As Range
Dim Ws As Worksheet
Set Ws = Sheets(1)
With Ws
Set rngDB = .Range("a2", .Range("a" & Rows.Count))
End With
For Each rng In rngDB
If InStr(LCase(rng), "mth") Or InStr(LCase(rng), "rtd") Or InStr(LCase(rng), "npt") Then
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End If
Next rng
If rngU Is Nothing Then
Else
rngU.EntireRow.Delete
End If
End Sub
VBA syntax of your Or is wrong,
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Should be:
If Cells(i, 1).Value = "mth" Or Cells(i, 1).Value = "rtd" Or Cells(i, 1).Value = "npt" Then
However, you need to use a string function, like Instr or Like to see if a certain string is found within a longer string.
Code
Option Explicit
Sub customized_row_removal()
Dim WordsArr As Variant
Dim WordsEl As Variant
Dim i As Long, LastRow As Long
Dim Sht As Worksheet
WordsArr = Array("mth", "rtd", "npt")
Set Sht = Worksheets("Sheet1")
With Sht
' get last row in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LastRow To 2 Step -1
For Each WordsEl In WordsArr
If LCase(.Cells(i, 1).Value) Like "*" & WordsEl & "*" Then
.Rows(i).Delete
End If
Next WordsEl
Next i
End With
End Sub
I try to make my code sample as I can if you have any question please ask
Private Sub remove_word_raw()
'PURPOSE: Clear out all cells that contain a specific word/phrase
Dim Rng As Range
Dim cell As Range
Dim ContainWord As String
'What range do you want to search?
Set Rng = Range("A2:A25")
'sub for the word
shorttext1 = "mth"
shorttext2 = "rtd"
shorttext3 = "npt"
'What phrase do you want to test for?
ContainWord1 = shorttext1
ContainWord2 = shorttext2
ContainWord3 = shorttext3
'Loop through each cell in range and test cell contents
For Each cell In Rng.Cells
If cell.Value2 = ContainWord1 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord2 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord3 Then cell.EntireRow.Delete
Next cell
End Sub
I've been working with some code that opens a workbook and finds values based off a reference cell. It searches for a string and takes the cell next to it. unfortunately i now have 2 cells in the workbook that 'contain' the reference string. one cells is "Current Score" the other is "Percentage of Current Score". Is there a way to state that I just want "Current Score" and nothing else in the cell.
Sorry if this is a tad wordy, I can provide the code if necessary
EDIT: Here is the code:
Sub Future_Score()
Dim r
Dim findValues() As String
Dim Wrbk As Workbook
Dim This As Workbook
Dim sht As Worksheet
Dim i
Dim tmp
Dim counter
Dim c As Range
Dim firstAddress
Dim rng As Range
ReDim findValues(1 To 3)
findValues(1) = "Curren" & "*" & "Core"
findValues(2) = "dummyvariable1"
findValues(3) = "dummyvariable2"
counter = 0
r = Range("A163").End(xlDown).Row
Set rng = Range(Cells(163, 1), Cells(r, 1))
Set This = ThisWorkbook
For Each tmp In rng
Workbooks.Open tmp
Set Wrbk = ActiveWorkbook
'For Each sht In Wrbk.Worksheets
Set sht = ActiveSheet
For i = 1 To 3
With sht.Range(Cells(1, 1), Range("A1").SpecialCells(xlCellTypeLastCell))
Set c = .Find(findValues(i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Offset(0, 1).Value
secondAddress = c.Offset(0, 3).Value
thirdAddress = c.Offset(0, 4).Value
Do
This.Activate
tmp.Offset(0, 4).Value = firstAddress
Set c = .FindNext(c)
counter = counter + 1
Loop While Not c Is Nothing And c.Value = firstAddress
End If
End With
Wrbk.Activate
Next
'Wrbk.Activate
'Next sht
Wrbk.Close
Next tmp
End Sub
Have played around with the code a bit. The dummy variables will be in use for other functions, but basically the gist is to open a workbook, find a cell, take the cell next to it, paste in the original workbook. The problem is it picks up multiple cells that contain a string. I have used "Curren" & "Core" as the macro doesn't seem to handle spaces in strings to well.
Change
Set c = .Find(findValues(i), LookIn:=xlValues)
to
Set c = .Find(findValues(i), LookIn:=xlValues, LookAt:=xlWhole)
to require that the entire cell match the search string, rather than just part of the cell.