How can I tell Excel to highlight rows by their row number. For instance, let's say I wanted row 6, 10, 150, 201 highlighted. Thanks.
Here is another one based on Mote's .EntireRow.Interior.ColorIndex
This one doesn't restrict you to enter the row numbers but gives the user the flexibility to choose the rows at runtime.
Option Explicit
Sub Sample()
Dim Ret As Range
On Error Resume Next
Set Ret = Application.InputBox("Please select the rows that you would like to color", "Color Rows", Type:=8)
On Error GoTo 0
If Not Ret Is Nothing Then Ret.EntireRow.Interior.ColorIndex = 6
End Sub
FOLLOWUP
Is there a way to write the macro to read the row numbers from a list and highlight the rows?
Yes there is a way. Let's say the list in Cell A1 to A10 then you can use this code
Option Explicit
Sub Sample()
Dim i As Long, sh As Worksheet
On Error GoTo Whoa
Application.ScreenUpdating = False
'~~> Set this to the sheet where the rows need to be colored
Set sh = Sheets("Sheet2")
'~~> Change Sheet1 to the sheet which has the list
With Sheets("Sheet1")
For i = 1 To 10
If Not Len(Trim(.Range("A" & i).Value)) = 0 And _
IsNumeric(.Range("A" & i).Value) Then _
sh.Rows(.Range("A" & i).Value).Interior.ColorIndex = 3 '<~~ Red
Next i
End With
LetsContinue:
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
As an alternative to Motes' answer, you can use conditional formatting.
Eg: select A1:J500, Conditional formatting >> New rule >> Use a formula...
For the formula enter: =OR(ROW()=6, ROW()=10, ROW()=150, ROW()=201)
For basic VBA code, you can always start recording a macro, perform the action, stop recording, look at what code was generated, and then clean that up to do what you want. For example, recording the action of highlighting a row (setting the value of Interior.Color) gives you:
Rows("13:13").Select
Range("C13").Activate
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
The selection commands and extraneous Interior properties can be removed giving you:
Rows("13:13").Interior.Color = 65535
Adding in the row multi-select:
Rows("6:6,10:10,150:150,201:201").Interior.Color = 65535
Summary:
Record macro
View Excel's version
Use/Edit what code you need
objWB.Cells(rowNum,201).EntireRow.Interior.ColorIndex = 6
etc
Update: Didn't realize the date on this, but thought I'd add this in since it was relevant to the chosen answer.
In addition to Siddharth Rout's answer, since I don't have enough rep to comment yet, you can dynamically figure out how many rows there are in your worksheet with these two lines. xlCellTypeConstants could be changed to another XlCellType constant that you need, and the range can always be changed to accommodate to your spreadsheet.
Dim numRows As Integer
numRows = Range("A2", Range("A1048576").End(xlUp)).SpecialCells(xlCellTypeConstants).Cells.Count
Sorry if it is not as concise or elegant as other answers, but it gets the job done. When I was writing code for my own application I needed to loop through my code. Also, instead of highlighting the entire row, I only needed to highlight a portion of the rows.
Sub Highlight()
Dim ThisWB As Workbook
Dim ThisWS As Worksheet
Dim rows(0 To 3) As Integer
Dim test As String
Set ThisWB = ActiveWorkbook
Set ThisWS = ThisWB.Sheets("Sheet1")
rows(0) = 6
rows(1) = 10
rows(2) = 150
rows(3) = 201
For i = 0 To 3
test = "A" & rows(i) & ":H" & rows(i)
ThisWS.Range(test).Interior.ColorIndex = 15
Next i
End Sub
You might be able to achieve the same thing using conditional formatting
put list of values in a column (I use a separate tab and give the list a name)
under conditional formatting - New Rule - "use a formula to determine with cells to format"
read this article http://www.howtogeek.com/howto/45670/how-to-highlight-a-row-in-excel-using-conditional-formatting/
the rule uses vlookup in the formula- =$A2=VLOOKUP($A2,list,1,FALSE)
Related
This is a continuation for the following question: What is the cause for Conditional Formatting to get jumbled up?
In an attempt to prevent my conditional formatting from going haywire, I decided to convert it into code in VBA. I decided to start small and start with converting one conditional formatting into VBA.
Explanation:
In column O there are a series of numbers, obtained from a different sheet. User inputs number in column F. For example if number in F9 is less than O9, the font colour will become red. If not number remains normal. The formula should start at row 9 and can continue down onwards and should be automatic.
Meaning the moment a number is keyed in column F the font colour should change instantly.
The following is the code I created so far:
Sub change_color()
With Me.Range("f9", Range("f" & Rows.Count).End(xlUp)) 'so the formula will carry onwards from f9 onwards
If f9 < o9 Then
Range(f).Font.Color = vbRed
End If
End With
End Sub
But alas it didn't work. I also tried linking it to a button and nothing happens. And I also remember to remove my old conditional formatting as well. Is there something I'm missing?
You are after something like the code below.
This code is to be ran once, it will lopp through the entire column "F" in your worksheet, and change the font of all instances.
Regular Module Code
Option Explicit
Sub change_color()
Dim LastRow As Long, i As Long
With Worksheets("Sheet1") ' modify to your sheet's name
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row
For i = 1 To LastRow
If .Range("F" & i).Value < .Range("O" & i).Value Then
.Range("F" & i).Font.Color = vbRed
Else
.Range("F" & i).Font.Color = vbBlack
End If
Next i
End With
End Sub
To "catch" the modification in real-time, when someone changes a value in column "F", and then change the font according to the criteria you specified, you need add the following code to the Worksheet module, where you have your data, and add the piece of code below to Worksheet_Change event.
Code in Sheet1 module (modify to your sheet's)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 6 Then ' if someone changes a value in column "F"
Application.EnableEvents = False
If Target.Value < Range("O" & Target.Row).Value Then
Target.Font.Color = vbRed
Else
Target.Font.Color = vbBlack
End If
End If
Application.EnableEvents = True
End Sub
Does this work for you?
Option explicit
Sub ChangeColor()
With thisworkbook.worksheets(YOURSHEETNAME) 'Replace with sheet name as per your workbook.'
Dim LastRow as long
Lastrow = .cells(.rows.count,"F").end(xlup).row
Dim RowIndex as long
For rowindex = 9 to LastRow
If .cells(rowindex,"F").value2 < .cells(rowindex,"O").value2 then
.cells(rowindex,"F").font.color = vbred
End if
Next rowindex
End With
End Sub
So, I need to make an Excel Macro in VBA that will search for a string, then compare it with a pre-set string of my choice and then change the value of a cell in another Sheet.
It goes like this:
Sub Macro1()
Dim A As Integer
Dim WS As Worksheet
Dim ToCompare, Coniburo As String
Coniburo = "My String"
For Each WS In Worksheets
For A = 1 To Rows.Count
ToCompare = Left(Cells(A, 3), 100)
If InStr(ToCompare, Coniburo) > 0 Then
Sheets("Last Sheet").Cells(21, 2).Value = "233"
End If
Next A
Next
The macro works....... If I remove the first For (the one that search through sheets) and as long as I'm in a sheet where "My string" is present. Otherwise, it doesn't work. It takes a long time to process, over a minute since there are 17 sheets.
Why isn't working? I read a lot of posts here, the Microsoft Dev forum, a site called Tech on the Net, and still there is something I'm missing, but I don't know why.
Can anybody point me in the right direction?
Use a With ... End With to focus the parent worksheet for each iteration of the loop.
Option Explicit
Sub Macro1()
Dim a As Long, Coniburo As String, ws As Worksheet
Coniburo = "My String"
For Each ws In Worksheets
With ws
For a = 1 To .Cells(.Rows.Count, "C").End(xlUp).Row
If CBool(InStr(Left(.Cells(a, 3), 100), Coniburo, vbTextCompare)) Then
Worksheets("Last Sheet").Cells(21, 2).Value = 233
End If
Next a
End With
Next
End Sub
You need to prefix Rows, Range and Cells calls with a period like .Rows... or .Range(...) or .Cells(...) when inside a With ... End With block. This identifies them with the parent worksheet described by the With .. End With.
I also made the comparison case-insensitive with vbTextCompare.
There is the remaining problem of writing and rewriting 233 into the same cell on the same worksheet but that is another matter.
I've bent the rules a little here but I want to show how we could use the built in FIND function to speed things up dramatically. Simply, we'll work through each sheet within column C only; we'll use the FIND function to find the ROW number where column C contains your search string.... then we'll double-check that cell to see if your search string is within the first 100 characters, per your requirement. If it is, we'll consider that a match. In addition to your result of logging "233" into the sheet "Last Page" I've included some bright green highlighting just to help see what's going on...
Sub findConiburo()
Coniburo = "My String"
For Each ws In Worksheets
With ws.Range("C:C")
myName = ws.Name 'useful for debugging
queue = 1 'will be used to queue the FIND function
x = 0 'loop counter
Do 'loop to find multiple results per sheet
On Error Resume Next 'Disable error handling
'FIND Coniburo within ws column C, log row number:
'Note ".Cells(queue, 1)" is a relative reference to the current WS, column C
foundRow = .Find(What:=Coniburo, After:=.Cells(queue, 1), LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Row
'If no result found then an error number is stored. Perform error handling:
If Err.Number <> 0 Then
'No results found, don't do anything, exit DO to skip to next sheet:
Exit Do
End If
On Error GoTo 0 'Re-enable error handling
If x = 0 Then
'first loop - log the first row result:
originalFoundRow = foundRow
ElseIf foundRow = originalFoundRow Then
'Not the first loop. Same result as original loop = we're back at the start, so exit loop:
Exit Do
End If
'Update queue so next loop will search AFTER the previous result:
queue = foundRow
'check if the string is not only SOMEWHERE in the cell,
'but specifically within the first 100 characters:
ToCompare = Left(.Cells(foundRow, 1), 100)
If InStr(ToCompare, Coniburo) > 0 Then
.Cells(foundRow, 1).Interior.ColorIndex = 4 'highlight green
Sheets("Last Sheet").Cells(21, 2).Value = "233"
End If
'Update loop counter:
x = x + 1
Loop
End With
Next ws
End Sub
I have data that I am working to Parse Out that I have imported from approval emails sent in Outlook. At this point I am just importing the CreationTime and the SubjectLine.
For the subject line I am able to use the Split function to separate out most of the data. I then am left with Job Codes in Column B and Position numbers in Column C which includes the text: "Job Codes: XXXX" and the four digit job code number and "PN XXXX" and either a four digit or 6 digit position number. I am trying to use the Right functionality to loop through the entire column and reformat the column just to show only the four digit job code number for Column B and either just the 4 digit or 6 digit position number (the actual numbers) for Column C
For Job Code Column B:
Currently my code works for Shortening the Job Codes but it involves adding a column, putting the RIGHT formula in that column for the shortened Job Code, then copying and pasting the formula as values back into the column and then deleting the original column.
The problem- Works but perhaps not the most efficient with a larger data set (currently 200 rows but will have 2000 or more)
Code:
Sub ShortenJobCodes()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC3,4)"
Dim oRng As Range
Dim LastRow As Long
Range("B1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set oRng = Range("B:B")
Range(oRng, Cells(LastRow, "B")).FormulaR1C1 = R4Col
Set oRng = Nothing
Columns("B").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("C1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
For Position Numbers Column C:
Currently I have mirrored the above code but added in an if statement using LEN to count if the characters are less than 8, if so then insert one RIGHT function if not insert the other RIGHT function. This also involves adding an additional column putting the RIGHT formula in that column for the shortened Position Number(Eliminating all but just the number), then copying and pasting the formula as values back into the column and then deleting the original column.
Problem - This works but seems to take forever to process and in fact looks like it is in an infinite loop. When I Esc out of it, it does add the column and then input the proper RIGHT formula (leaving just the numeric values) but the sub never seems to end, nor does it copy and paste the formulas as values or delete the original column. As noted above I realize this is likely a more efficient way to do this but I have tried a bunch of options without any luck.
I am realizing part of the loop might be due to the range itself being an entire column but I cannot find a way to stop that with the last row (even though I have a count in there).
Code:
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Const R4Col = "=RIGHT(RC4,4)"
Const R6Col = "=RIGHT(RC4,6)"
Dim oRng As Range
Dim rVal As String
Dim y As Integer
Dim selCol As Range
Dim LastRow As Long
Range("C1").EntireColumn.Insert
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = Range("D:D")
For Each oRng In selCol
oRng.Select
rVal = oRng.Value
If Len(oRng.Value) > 8 Then
oRng.Offset(0, -1).FormulaR1C1 = R6Col
Else
oRng.Offset(0, -1).FormulaR1C1 = R4Col
End If
Next
Set oRng = Nothing
Columns("C").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Range("D1").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
Major Question: Is there a way to use RIGHT/TRIM/LEN/LEFT functions to do this within a cell without having to add columns/delete columns and insert functions?
There are a few things you can do here to speed up your code. I'm only going to reference the second code block as you can apply similar logic to the first.
The first issue is that you create a LastRow variable but never reference it again. It looks like you meant to use this in the selCol range. You should change that line to Set selCol = Range("C1:C" & lastRow). This way, when you loop through the rows you only loop through the used rows.
Next, in the For-Each loop you Select every cell you loop through. There really isn't any reason to do this and takes substantially longer. You then create the variable rVal but never use it again. A better way to set up the loop is as follows.
For Each oRng in selCol
rVal = oRng.Value
If Len(rVal) > 8 Then
oRng.Value = Right(rVal, 6)
Else
oRng.Value = Right(rVal, 4)
End If
Next
This is much cleaner and no longer requires creating columns or copying and pasting.
Try this, it uses Evaluate and no loops or added columns.
Sub ShortenPositionNumbers()
Application.ScreenUpdating = False
Dim selCol As Range
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set selCol = .Range(.Cells(1, 3), .Cells(LastRow, 3))
selCol.Value = .Evaluate("INDEX(IF(LEN(" & selCol.Address(0, 0) & ")>8,RIGHT(" & selCol.Address(0, 0) & ",6),RIGHT(" & selCol.Address(0, 0) & ",4)),)")
End With
Application.ScreenUpdating = True
End Sub
Or work with arrays
Sub ShortenPositionNumbers()
Dim data As Variant
Dim i As Long
With Range("C3:C" & Cells(Rows.Count, "A").End(xlUp).Row)
data = Application.Transpose(.Value)
For i = LBound(data) to UBound(data)
If Len(data(i)) > 8 Then
data(i) = RIGHT(data(i),6)
Else
data(i) = RIGHT(data(i),4)
End If
Next
.Value = Application.Transpose(data)
End With
End Sub
First and foremost, the below works as expected. I'm trying to make the macro mimic one we have in word. Our word macro will select the entire column simply to display which column is currently being processed (the selection object is not used for any actual processing).
In excel, when I attempt to select the column (activecell.entirecolumn.select) if there is a merged cell it will show multiple columns. I need it only to select the letter column (pretty much the same as clicking the letter at the top) of the active cell. I'm hoping for a method that wont require me to parse the address of the cell if possible (I feel like string parsing is sloppy).
Sub setwidths()
Dim rangeName As String
Dim selectedRange As range
Dim tempRange As range
Dim x As Integer
'If only 1 cell is selected, attempt to find the correct named range
If Selection.Cells.Count = 1 Then
rangeName = Lib.getNamedRange(Selection) 'Built in function from my lib (works I promise)
If rangeName <> "" Then
Application.Goto reference:=rangeName
End If
End If
Set selectedRange = Selection
'Go column by column asking for the width
'Made to mimic a word MACRO's behavior and moving backwards served a point in word
For x = selectedRange.Columns.Count To 1 Step -1
Set tempRange = selectedRange.Columns(x)
tempRange.Cells(tempRange.Cells.Count, 1).Select
'This is where the code should go to select the column
tempRange.ColumnWidth = InputBox("This columns?")
Next
End Sub
Is there anyway to select a column by letter (range("A:A").select for instance) from within an active cell?
Edit:
Record MACRO shows that columns("A:A").select is used when clicking the letter at the top; however, entering that same line into the immediate window will select all columns that merged cells are merged across same as with range("A:A").select and activecell.selectcolumn
Sub NSTableAdjust()
Dim rangeName As String
Dim selectedRange As range
Dim tempRange As range
Dim cellsColor() As Long
Dim cellsPattern() As XlPattern
Dim cellsTaS() As Long
Dim cellsPTaS() As Long
Dim result As String
Dim abort As Boolean
Dim x As Integer
Dim y As Integer
'Delete the block between these comments and run macro on 10x10 grid in excel to test
If Selection.Cells.Count = 1 Then
rangeName = Lib.getNamedRange(Selection)
If rangeName <> "" Then
Application.Goto reference:=rangeName
End If
End If
'Delete the block between these comments and run macro on 10x10 grid in excel to test
Set selectedRange = Selection
ReDim cellsArr(1 To selectedRange.Rows.Count)
ReDim cellsColor(1 To UBound(cellsArr))
ReDim cellsPattern(1 To UBound(cellsArr))
ReDim cellsTaS(1 To UBound(cellsArr))
ReDim cellsPTaS(1 To UBound(cellsArr))
abort = False
For x = selectedRange.Columns.Count To 1 Step -1
Set tempRange = selectedRange.Columns(x)
tempRange.Cells(tempRange.Cells.Count, 1).Select
For y = 1 To UBound(cellsColor)
With tempRange.Cells(y, 1).Interior
cellsColor(y) = .Color
cellsPattern(y) = .Pattern
cellsTaS(y) = .TintAndShade
cellsPTaS(y) = .PatternTintAndShade
.Color = 14136213
End With
Next
result = InputBox("This Column?")
If IsNumeric(result) Then
tempRange.ColumnWidth = result
Else
abort = True
End If
For y = 1 To UBound(cellsColor)
With tempRange.Cells(y, 1).Interior
.Color = cellsColor(y)
.Pattern = cellsPattern(y)
.TintAndShade = cellsTaS(y)
.PatternTintAndShade = cellsPTaS(y)
End With
Next
If abort Then
Exit Sub
End If
Next
End Sub
My current solution to simply shade the cells and then restore their original shading after processing the column.
After an obviously lengthy discussion in the comments on the post. It appears the answer to my question is simply "Not Possible."
The solution I settled on in an attempt to get as close to the "Look" I was searching for is below:
For x = selectedRange.Columns.Count To 1 Step -1
Set tempRange = selectedRange.Columns(x) 'Range of the column
'Our standards dictate the last cell in the range will not be merged
With tempRange.Cells(tempRange.Cells.Count, 1)
.Select 'Selecting here will for excel to make sure the range is in view
'Very simple/basic conditional formatting rule
Set fCondition = .EntireColumn.FormatConditions. _
Add(Type:=xlExpression, Formula1:="=True")
fCondition.Interior.Color = 15123099
'Make sure it is the highest priority rule
fCondition.Priority = 1
End With
'Get user input
result = InputBox("This Column?")
'Delete rule
fCondition.Delete
'Validate user input
If IsNumeric(result) Then
tempRange.ColumnWidth = result
Else
abort = True
End If
If abort Then
Exit Sub
End If
Next
Screenshot
I am updating a word list (2) with the frequency ranking of another list (1). The code is designed to for every entry in list 1 go through list 2 and add the frequency ranking to every identical entry in it. If I limit the list to a few entries in each, it works exactly as intended, but the lists are quite large. List 1 contains 55.000 words and list 2 contains 18.000 words. Is there a way to prevent the code from crashing, or alternatively rewrite it in a more efficient manner? I am sure it is far from optimal, as I am a complete neophyte in VBA. I’ll paste in the code below.
Thanks much
Option Explicit
Sub CorrectFrequencyData()
Dim Frequency As Double
Dim CurrentLocation As Range
Application.ScreenUpdating = False
Set CurrentLocation = Range("i5")
Do Until CurrentLocation.Value = ""
Frequency = CurrentLocation.Offset(0, -6).Value
Range("n4").Activate
Do Until ActiveCell.Value = ""
If ActiveCell.Value = CurrentLocation.Value Then ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value + Frequency
ActiveCell.Offset(1, 0).Activate
Loop
Set CurrentLocation = CurrentLocation.Offset(1, 0)
Loop
Application.ScreenUpdating = True
End Sub
It Looks like there may be a few ways to speed up your code. Firstly you could use a SUMIF as GavinP suggested like so in your second frequency column =SUMIF(I:I, N4, C:C) If you flow this down for your second frequency column what this is saying is check column I for the value in N + row and everywhere that you find that value at the frequency from column C to a Total.
Now options to speed up your code:
Option Explicit
Sub CorrectFrequencyData()
Application.ScreenUpdating = False
I'm not sure if you have formulas in your code but you can set them to manual instead of having them recalculate every time you change values on your sheet.
Application.Calculation = -4135 'xlCalculationManual
Instead of looping through your sheet you can assign your range to an array and loop through that which is faster. We can also eliminate the need to loop through the second list for every entry in the first list. We'll do this by storing the first list of words and their frequency in a dictionary
Dim ArrWords() as variant
Dim LastRow as long
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 9).End(-4162).Row 'Version non-specific Endrow, xlUP
ArrWords = Range("C4:I" & LastRow)
Dim dicWordFrequency as Object
Set dicWordFrequency = CreateObject("Dictionary.Scripting")
Dim tempWord as String
Dim i as Long
For i = 1 to Ubound(ArrWords)
tempWord = arrWords(i,7)
If not dicWordFrequency.Exists(tempWord) then
DicWordFrequency.Add tempWord, arrWords(i,1)
Else
DicWordFrequency.Item(tempWord)= dicWordFrequency.Item(tempWord) + arrWords(i,1)
End If
Next
Now we can loop through your worksheet and update the frequencies for the words in the second list.
LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 14).End(-4162).Row 'Version non-specific Endrow, xlUP
ArrWords = Range("N4:O" & LastRow)
For i = 1 to Ubound(arrWords)
tempWord = arrwords(i,1)
If dicWordFrequency.Exists(tempWord) then
arrWords(i,2) = dicWordFrequency.Item(tempWord)
End If
Next
'Dump your new array with the totals to a range
Dim result as Range
Set Result = Range("N4")
Result.ReSize(UBound(arrWords,1), Ubound(ArrWords,2)).value = arrWords
Application.ScreenUpdating = True
Application.Calculation = -4105 'xlCalculationAutomatic
End Sub