I am writing the code below in VBA macro excel, my problem is that I get the object our of range error in the line (107, col 10) and I don't know why.
the line I get the error
.Range(.Cells(x, "A"), .Cells(x, "AC")).Select
my code is below
Sub MRP()
'
' Macro1 Macro
'
'
Dim wks As Worksheet
Dim OPwks As Worksheet
Dim MRPwks As Worksheet
Dim OPDwks As Worksheet
Dim DbCwks As Worksheet
Dim x As Long
Dim p As Integer, i As Long, q As Long
Dim a As Integer, m As Integer, k As Long
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRowOPwks As Long
Dim LastRowMRPwks As Long
Dim LastRowDBCwks As Long
Set MRPwks = Worksheets("MRP")
Set OPwks = Worksheets("OpenPOsReport")
Set DbCwks = Worksheets("CompDB")
Set wks = ActiveSheet
Worksheets("OpenPOsReport").Activate
LastRowMRPwks = MRPwks.Cells(MRPwks.Rows.Count, "A").End(xlUp).Row
LastRowOPwks = OPwks.Cells(OPwks.Rows.Count, "A").End(xlUp).Row
LastRowDBCwks = DbCwks.Cells(DbCwks.Rows.Count, "A").End(xlUp).Row
'Set rowRange = wks.Range("A1:A" & LastRow)
'For m = 8 To LastRow
'Cells(m, "N") = 0
'Next m
For i = 2 To LastRowDBCwks
p = 0
For q = 8 To LastRowOPwks
If DbCwks.Cells(i, "V") = 0 Then k = 0 Else: k = p / Cells(i, "V")
If OPwks.Cells(q, "A") = DbCwks.Cells(i, "A") Then
If OPwks.Cells(q, "D") = 0 Or OPwks.Cells(q, "B") < 1 / 1 / 18
Then GoTo Nextiteration Else
If (OPwks.Cells(q, "C") + DbCwks.Cells(i, "C")) >=
(DbCwks.Cells(i, "F") + k) Then
OPwks.Cells(q, "N").Value = 1
OPwks.Range(Cells(q, "A"), Cells(q, "N")).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
p = p + OPwks.Cells(q, "D").Value
OPwks.Cells(q, "N").Value = 0
OPwks.Range(Cells(q, "A"), Cells(q, "O")).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
Nextiteration:
Next q
Next i
'For q = 8 To LastRow
' If Cells(q, "N") = 1 Then
' End If
' Next
With MRPwks
For x = 5 To LastRowMRPwks
If .Cells(x, "AC").Value > 0 Then
.Range(.Cells(x, "A"), .Cells(x, "AC")).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If .Cells(x, "AC") = 0 Then
.Range(.Cells(x, "A"), .Cells(x, "AC")).Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next x
End With
End Sub
I dont know why I get the Object out of range error in the first part of the code.
You have Worksheets("OpenPOsReport").Activate in your code, then you try to select .Range(.Cells(x, "A"), .Cells(x, "AC")).Select on MRPwks which is not active at that time. This is not possible.
Change your code to
With MRPwks
For x = 5 To LastRowMRPwks
If .Cells(x, "AC").Value > 0 Then
With .Range(.Cells(x, "A"), .Cells(x, "AC")).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If .Cells(x, "AC") = 0 Then
With .Range(.Cells(x, "A"), .Cells(x, "AC")).Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next x
End With
It is not neccessary to select the range first.
You can avoid this error if you don't try to Select the range (because you cannot select a range on a sheet that's inactive). One common mistake is to say "OK, well, then I'll just add a .Activate to make sure the right sheet is active. But that leads to spaghetti code, as you constantly need to keep track of which sheet in which workbook is active, makes the code hard to read and harder to debug.
Selecting/Activating things in Excel is almost never necessary, and when you do it this way it tends to cause all sorts of difficult-to-troubleshoot errors, like the one you have.
Dim rngToFormat as Range
For x = 5 To LastRowMRPwks
Set rngToFormat = .Cells(x, "A").Resize(1,29)
If rngToFormat.Cells(29).Value > 0 Then
With rngToFormat.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With rngToFormat.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next x
Related
I'll try to get all the info out here... I have a query table (A1:E120 w/headers) on one sheet, and a nicely formatted table (B1:F120 w/headers) on another, I have a macro that updates the formatted table from the query table by this subroutine:
Module 1:
Sub UpdateLedger()
Dim Lgr1 As ListObject
Dim LgrSource As ListObject
Dim UniqueRowEntry As String
Dim n As Long
UniqueRowEntry = Cells(2, 6).Value
n = Sheets(5).UsedRange.Find(UniqueRowEntry, LookIn:=xlValues).Row - 2
Application.EnableEvents = False *I have a row highlight selection event
Set Lgr1 = Sheets(4).ListObjects(1)
Set LgrSource = Sheets(5).ListObjects(1)
For i = 1 To n
If Not Lgr1.ListRows(i).Range.Cells(1).Value = LgrSource.ListRows(i).Range.Cells(1).Value Then
If Not Lgr1.ListRows(i).Range.Cells(5).Value = LgrSource.ListRows(i).Range.Cells(5).Value Then
Lgr1.ListRows.Add (i)
Lgr1.ListRows(i).Range.Value = LgrSource.ListRows(i).Range.Value
End If
End If
Next i
Application.EnableEvents = True
End Sub
This Sub works great! but, when I was debugging it kept jumping over to these when it added the row! :
Module 2:
Global CText As Range
Global SText As String
Global SWks As Integer
Private Function TextFind(wks As Integer, SearchText As String) As String
Dim SearchResult As Range
Set SearchResult = Worksheets(wks).UsedRange.Find(SearchText)
Set CText = SearchResult
SText = SearchText
SWks = wks
TextFind = SearchResult.Address
Debug.Print SearchResult.Address
End Function
Private Function NextText() As String
Dim SearchNext As Range
Dim ContinueBox As Variant
Set SearchNext = Worksheets(SWks).UsedRange.Find(What:=SText, After:=CText, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If SearchNext Is Nothing Then
ContinueBox = MsgBox("Clear Search Settings?", vbYesNo, "Next " & SText & " not found!")
If ContinueBox = vbYes Then
Set CText = Nothing: SText = "": SWks = Empty
ElseIf ContinueBox = vbNo Then
NextText = ""
End If
Else
NextText = SearchNext.Address
'Debug.Print SearchNext.Address
Set CText = SearchNext
End If
End Function
Private Function ReadCell(RType As String, RCell As Range, SheetNum As Long) As Variant
Dim addr As String
Select Case True
Case InStr(UCase(RType), UCase("row")) > 0
ReadCell = Worksheets(SheetNum).Range(RCell.Value).Row
Case InStr(UCase(RType), UCase("col")) > 0
ReadCell = Worksheets(SheetNum).Range(RCell.Text).Column
Case InStr(UCase(RType), UCase("val")) > 0
ReadCell = Worksheets(SheetNum).Range(RCell.Text).Value
Case Else
ReadCell = Error
End Select
End Function
Sub FindSomeText()
MsgBox InStr("Look in this string", "in")
End Sub
When I disable one of these functions with 's then it just jumps to a different one! So I have to disable ALL of them for the subroutine to function! It just doesn't make any sense to me... the function names are not accidentally sneaking into the code for the table update (and I would prefer to know WHY this is happening, instead of just "Well, those were one time practice functions, so I guess I'll delete them and go on with life"
I don't know if it helps any but here is the highlight selection event that is on the formatted table's sheet code:
Sheet4:
Sub worksheet_selectionchange(ByVal Target As Range)
Dim x, y, i, j, n As Long
Dim rng1, cell As Range
If Target.Column > 5 Or Target.Column < 2 Then Exit Sub
If tgb1.Value = False Then Exit Sub
x = UsedRange.Rows.Count
y = UsedRange.Find("Amount").Column - 1
Set cell = Range(Cells(2, 2), Cells(x, y))
Set rng1 = Application.Union(Target, cell)
If Range(Cells(2, 2), Cells(x, y)).Cells.Count = Application.Union(Target, cell).Cells.Count Then
Setformats
If Cells(Target.Row, UsedRange.Find("amount").Column) < 0 Then
With Range(Cells(Target.Row, 2), Cells(Target.Row, y))
.Font.FontStyle = "Bold"
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 3
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 3
.TintAndShade = 0
.Weight = xlThin
End With
End With
Cells(Target.Row, 1).Select
ElseIf Cells(Target.Row, UsedRange.Find("amount").Column) > 0 Then
With Range(Cells(Target.Row, 2), Cells(Target.Row, y))
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 4
.TintAndShade = 0
.Weight = xlHairline
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 4
.TintAndShade = 0
.Weight = xlHairline
End With
End With
Cells(Target.Row, 1).Select
End If
End If
End Sub
Public Sub Setformats()
Dim x, y, i, j, n As Long
x = ActiveSheet.UsedRange.Rows.Count - 1
y = ActiveSheet.UsedRange.Columns.Count - 1
With Worksheets("USBank").Range(Cells(2, 2), Cells(x, y))
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Font.FontStyle = "regular"
End With
End Sub
Note: It's a bank statement(so can't show ya), 5 columns: Date, Action(debit or credit), Transaction(purchase, deposit, fee..), Vendor(Joe's Coffee),Amount(+/- $2.14) ...the scope of this project is just to increase skills in VBA
I would like write a VBA code to select a group of cells that has the same value and colour it.
MySpreadSheet
For Row A, Staff ID, are the same, for the same person, I intend to scan through them and if they are the same, fill the cells with the light blue colour you see in the picture above, for Column A to MaxColumn of Current Region.
I have a drafted a code to do that but it does nothing when I run it. Any help will be appreciated:
Sub ActualColouring()
Dim SerialNumber As Integer
SerialNumber = 2 'this variable will be assign to the rows, ignore the header, start from 2
Do While Cells(1, SerialNumber).Value <> "" 'keep looping as long as cell is not blank
If Cells(1, SerialNumber).Value = Cells(1, SerialNumber + 1).Value Then 'if the value of the cell is the same as the cell below, then
Cells(1, SerialNumber).Select 'then select it
With Selection.Interior 'this line is the start of the fill colouring
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With 'end of fill colouring function
End If
SerialNumber = SerialNumber + 1 'move to the next cell
Loop 'loop until the end of current region
End Sub
Qualify the objects and avoid select
Sub ActualColouring()
Dim ws as Worksheet
Set ws = ThisWorkbook.Worksheets("mySheet") ' change name as needed
With ws
Dim SerialNumber As Long, lRow as Long
lRow = .Range("A" & .Rows.Count).End(xlup).Row
For SerialNumber = 2 to lRow
If .Cells(1, SerialNumber).Value = .Cells(1, SerialNumber + 1).Value Then
With .Cells(1, SerialNumber).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
End If
Next
End With
End Sub
i am a newbie in VBA, so i come across with several issues.
I have a dataset that looks like this:
I have to compare column A with columns B,C,D,E and F and then color the fonts of the cells in columns B:F under these conditions:
If cells in column A are equal with the cells in columns B:F, paint their font orange.
If cells in column A are higher than the cells in columns B:F, paint their font red.
If cells in column A are lower than the cells in columns B:F, paint their font green.
If the absolute difference between column A and the rest columns (B:F) is less than 1, paint their font orange.
I have tried to write a simple macro and all conditions are met except the 4th.
Here is my attempt.
Sub ConditionalFormating()
Dim i, j, a As Double
a = 0.99
i = 2
j = 2
For j = 1 To 6
For i = 2 To 10
ActiveSheet.Cells(i, j).Select
If ActiveSheet.Cells(i, j) - ActiveSheet.Cells(i, 1) >= a Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 156, 0)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If ActiveSheet.Cells(i, j) - ActiveSheet.Cells(i, 1) <= a Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 156, 0)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If ActiveSheet.Cells(i, j) > ActiveSheet.Cells(i, 1) Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(0, 255, 0)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
If ActiveSheet.Cells(i, j) < ActiveSheet.Cells(i, 1) Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 0, 0)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next
Next
End Sub
Could anyone help me? I cannot understand why the 4th condition is not met when all others are.
Thank you in advance!
To color the font, you have to use the Font property of Range, like: Selection.Font.Color=RGB(255,128,0).
you could try this (commented) code:
Option Explicit
Sub ConditionalFormating()
Dim cell As Range, cell2 As Range, dataRng As Range
Dim colOrange As Long, colRed As Long, colGreen As Long, col As Long
colOrange = RGB(255, 156, 0)
colRed = RGB(255, 0, 0)
colGreen = RGB(0, 255, 0)
With Worksheets("CF") '<--| reference the relevant worksheet (change "CF" to your actual worksheet name)
Set dataRng = Intersect(.Columns("B:F"), .UsedRange)
For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants) '<-- loop through its column "A" not empty cells from row 1 down to last not empty one
If WorksheetFunction.CountA(Intersect(dataRng, cell.EntireRow)) > 0 Then ' if current row has data
For Each cell2 In Intersect(dataRng, cell.EntireRow).SpecialCells(xlCellTypeConstants) ' loop through current column "A" cell row not empty cells
Select Case True '<-- check the current datum against the following conditions
Case cell2.Value = cell.Value Or Abs(cell.Value - cell2.Value) < 1 'if current datum equals corresponding value in column "A" or their absolute difference is lower than 1
col = colOrange
Case cell2.Value < cell.Value 'if current datum is lower then corresponding value in column "A"
col = colRed
Case cell2.Value > cell.Value 'if current datum is higher then corresponding value in column "A"
col = colGreen
End Select
With cell2.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = col
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next cell2
End If
Next cell
End With
End Sub
How could I edit my code to only highlight the row from column G:K instead of wasting memory and time highlighting the entire row?
With ActiveSheet 'set this worksheet properly!
'lastrow = .cells(Rows.Count, 1).End(xlUp).Row
lastrow = Range("K6500").End(xlUp).Row - 2
For Each cell In .Range("K3:K" & lastrow)
If cell = "Wrong Date" Then
'With cell.EntireRow.Interior
With cell.Range("G:K").Value.Interior.ColorIndex = 3
Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 3937500
.TintAndShade = 0
.PatternTintAndShade = 0
End With
My current code does not work as I've tried replacing With cell.EntireRow.Interior with With cell.Range("G:K").Value.Interior.ColorIndex = 3
Excuse me this is what I mean I am trying to do
Sub highlight_wrong_Date()
Dim Rng As Range, lCount As Long, lastrow As Long
Dim cell As Object
With ActiveSheet 'set this worksheet properly!
lastrow = Range("K6500").End(xlUp).Row - 2
For Each cell In .Range("K3:K" & lastrow)
If cell = "Wrong Date" Then
With cell.Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 3937500
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf cell = "Pass" Then
With cell.Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 61046
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With cell.EntireRow.Interior
Rows().Select
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next cell
End With
End Sub
But I receive an error saying the cell object does not support this. If a cell has either a value of "Wrong Date" or "Pass" within column O I want to highlight red or green respectively.
3rd Edit
Sub highlight_wrong_Date()
Dim Rng As Range, lCount As Long, lastrow As Long
Dim cell_value As Object
With ActiveSheet 'set this worksheet properly!
lastrow = Range("K6500").End(xlUp).Row - 2
For Each cell_value In .Range("K3:K" & lastrow)
If cell_value = "Wrong Date" Then
With .Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
'Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 3937500
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ElseIf cell_value = "Pass" Then
With .Range(.cells(cell.Row, "G"), .cells(cell.Row, "K"))
'Rows().Select
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 61046
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Else
With cell.EntireRow.Interior
Rows().Select
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next cell_value
End With
End Sub
Your references should be
With .Range("G" & cell.Row & ":K" & cell.Row)
I would like a cell to become highlighted if its value is present in each of the other columns.
Below is the part of the code that I can make work. I've tried nesting additional For-loops to represent new columns, but this doesn't work because it counts the cells in the original column, and ends up highlighting everything. I've also changed the If line to:
If Cells(i,1)=Cells(j,2)=Cells(k,3) Then
but this doesn't work either. Below is the code:
Sub check()
For i = 1 To 10
For j = 1 To 10
If Cells(i, 1) = Cells(j, 2) Then
Cells(i, 1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = -0.249977111117893
End With
End If
Next j
Next i
End Sub
Sub check()
Dim LastCol As Long
Dim LastRow As Long
Dim chkRng As Range
Dim Srch As String
Dim CurCol As Long
LastRow = Range("A" & Rows.Count).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Set chkRng = ActiveSheet.Range(Cells(1, 1), Cells(LastRow, LastCol))
For CurCol = 1 To LastCol
For CurRow = 1 To LastRow
Srch = Cells(CurRow, CurCol).Value
Cells(CurRow, CurCol).Value = ""
If Not chkRng.Find(Srch, LookIn:=xlValues, lookat:=xlWhole) Is Nothing Then
With Cells(CurRow, CurCol).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent6
.TintAndShade = -0.249977111117893
End With
Else
End If
Cells(CurRow, CurCol).Value = Srch
Next CurRow
Next CurCol
End Sub