I am still a novice VBA user. I can't seem to get my head around why this bit of script is not working. I get a
'Subscript Out of Range' error
on the second line in the If statement of the below:
Sub ScreenUpdate()
Dim LastRow As Long, LastColumn As Long, i As Long, j As Long
Application.ScreenUpdating = False
LastRow = Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
If Cells(i, 17).Value = Cells(i - 1, 17).Value Then
Cells(i, 1).NumberFormat = ";;;"
Cells(i, 2).NumberFormat = ";;;"
Cells(i, 15).NumberFormat = ";;;"
Cells(i, 16).NumberFormat = ";;;"
Else
Cells(i, 1).NumberFormat = "0"
Cells(i, 2).NumberFormat = "0"
Cells(i, 15).NumberFormat = "0"
Cells(i, 16).NumberFormat = "0"
End If
Next i
For j = 2 To LastRow
If Cells(j, 17).Value Mod 2 = 1 Then
Range(Cells(j, 1), Cells(j, 16)).Interior.ColorIndex = RGB(221, 235, 247)
Else
Range(Cells(j, 1), Cells(j, 16)).Interior.ColorIndex = RGB(255, 255, 255)
End If
Next j
Application.ScreenUpdating = True
End Sub
Many thanks for your assistance!
You've mixed up Color, which you would use the RGB function with, and ColorIndex.
The RGB function returns a Long whole number corresponding to the color value. Specifically in this case,
RGB(221, 235, 247) returns 16,247,773
RGB(255, 255, 255) returns 16,777,215
Both of these are outside the very narrow range of possible values for a color index in the current color palette, hence the subscript out of range.
Change each instance of ColorIndex to Color.
Related
I am trying to use this code in Excel to get a product color from column AW and then replace the value in column J with the SKU for that product color. It works, except it pastes the formula in column AY for EVERY row, instead of just the rows where the column J value is "WCblack", so that causes it to run pretty slowly.
Any ideas how I can get it to only put the formula in rows where column J value is "WCblack"? Thanks!
Sub Macro1()
Dim lastRow As Long, i As Long
lastRow = Cells(Rows.Count, "K").End(xlUp).Row
For i = 2 To lastRow
If Cells(i, "J").Value = "WCblack" Then
Range("AY2:AY" & lastRow).Formula = "=TRIM(LEFT(AW2,FIND(CHAR(10),AW2)-1))"
If Cells(i, "AY").Value = "Color: Red" Then
Cells(i, "J").Value = "WCred"
ElseIf Cells(i, "AY").Value = "Color: Gold" Then
Cells(i, "J").Value = "WCgold"
ElseIf Cells(i, "AY").Value = "Color: Blue" Then
Cells(i, "J").Value = "WCblue"
End If
End If
Next
End Sub
Im trying to write a VBA script to compare two = rows and have the spreadsheet highlight the duplicate rows only if certain criteria is met, such as (Value of row, column a = Value of row-1, column) AND Value of row, column b > Value of row-1, column b) Then entirerow of the greater value in column b.font.color = vbRed.
Here is a section of the table I'm running...
Table Selection
Here is the code I am using...
Sub RemoveDuplicates()
Dim i As Long, R As Long
'Dim DeviceName As Range, SerialNumber As Range, LastContact As Range
Application.ScreenUpdating = False
R = Cells(Rows.Count, 1).End(xlUp).Row
'Set DeviceName = Columns(2)
'Set SerialNumber = Columns(3)
'Set LastContact = Columns(7)
For i = R To 2 Step -1
'If Cells(i, "F").Value > Cells(i - 1, "F").Value Then
'Code above doesn't work
If Cells(i, 3).Value = Cells(i - 1, 3).Value And Cells(i, 2).Value = Cells(i - 1, 2).Value Then
'If Cells(i, 3).Value = Cells(i - 1, 3).Value And Cells(i, 2).Value = Cells(i - 1, 2).Value And Cells(i, 5).Value > Cells(i - 1, 5).Value Then
'Code above doesn't work
Cells(i, 1).EntireRow.Font.Color = vbRed
End If
Next i
Application.ScreenUpdating = True
End Sub
I can get the duplicates to highlight, but when I try to introduce the greater than check, the system gets janky.
try a conditional formatting rule.
With worksheets("sheet1").usedrange.offset(1, 0).entirerow
.FormatConditions.Delete
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=and($a2=$a1, $b2=$b1, $f2>$f1)")
.font.Color = vbRed
End With
End With
VBA procedure to compare two different columns in two different worksheets and highlight the different cells in this column and change the equal cells value to a new sequential number - the data doesn't have to be sorted before using the macro
this code will highlight values not in both lists:
Option Explicit
Sub main()
Dim report1 As Worksheet, report2 As Worksheet
Set report1 = Worksheets("Sheet1")
Set report2 = Worksheets("Sheet2")
Dim ids1 As Variant, ids2 As Variant
With report1
ids1 = Application.Transpose(.Range("B2", .Cells(Rows.Count, "B").End(xlUp)).Value)
End With
With report2
ids2 = Application.Transpose(.Range("D2", .Cells(.Rows.Count, "D").End(xlUp)).Value)
End With
ProcessOneReport report1, 2, ids2
ProcessOneReport report2, 4, ids1
End Sub
Sub ProcessOneReport(report As Worksheet, icol As Long, ids As Variant)
Dim validIdsRng As Range
With report
With .Range(.Cells(1, icol), .Cells(.Rows.Count, icol).End(xlUp))
.AutoFilter Field:=1, Criteria1:=ids, Operator:=xlFilterValues
If Application.WorksheetFunction.Subtotal(103, .Cells) < .Count Then
With .Resize(.Rows.Count - 1).Offset(1)
Set validIdsRng = .SpecialCells(xlCellTypeVisible)
.AutoFilter
validIdsRng.EntireRow.Hidden = True
With .SpecialCells(XlCellType.xlCellTypeVisible)
.Interior.Color = RGB(156, 0, 6) 'Dark red background
.Font.Color = RGB(255, 199, 206) 'Light red font color
End With
validIdsRng.EntireRow.Hidden = False
End With
End If
End With
.AutoFilterMode = False
End With
End Sub
' data are in column b and column d in sheet 1 and sheet2 respectively.
' data doesn't have to be sorted
' the student ids which are not available in both columns, will be highlighted and have a cell's color background.
'Get the last row
Dim Report As Worksheet
Dim i As Integer, j As Integer
Dim lastRow As Integer
Set Report = Excel.Worksheets("Sheet1") 'You could also use Excel.ActiveSheet _
if you always want this to run on the current sheet.
Set Report2 = Excel.Worksheets("Sheet2")
'lastRow = Report.UsedRange.Rows.Count
lastRow = 29
Application.ScreenUpdating = False
Dim seqNo As Integer, seqNo2 As Integer
seqNo = 0
seqNo2 = 0
For i = 2 To lastRow
For j = 2 To lastRow
If Report.Cells(i, 2).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
If InStr(1, Report2.Cells(j, 4).Value, Report.Cells(i, 2).Value, vbTextCompare) > 0 Then
'You may notice in the above instr statement, I have used vbTextCompare instead of its numerical value, _
I find this much more reliable.
Report.Cells(i, 2).Interior.Color = RGB(255, 255, 255) 'White background
Report.Cells(i, 2).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
Report.Cells(i, 2).Interior.Color = RGB(156, 0, 6) 'Dark red background
Report.Cells(i, 2).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next j
Next i
'Now I use the same code for the second column, and just switch the column numbers.
For i = 2 To lastRow
For j = 2 To lastRow
If Report2.Cells(i, 4).Value <> "" Then
If InStr(1, Report.Cells(j, 2).Value, Report2.Cells(i, 4).Value, vbTextCompare) > 0 Then
Report2.Cells(i, 4).Interior.Color = RGB(255, 255, 255) 'White background
Report2.Cells(i, 4).Font.Color = RGB(0, 0, 0) 'Black font color
seqNo2 = seqNo2 + 1
Report2.Cells(i, 4).Value = seqNo2
Report.Cells(j, 2) = seqNo2
Exit For
Else
Report2.Cells(i, 4).Interior.Color = RGB(156, 0, 6) 'Dark red background
Report2.Cells(i, 4).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
a better answer to compare two columns (column A and A )in two different worksheets (sheet1 and sheet2) and highlight similar cells with same fill green colour.
Sub Demo()
Dim lastRow1 As Long, lastRow2 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Long, j As Long, seqNo As Long
Set ws1 = Excel.Worksheets("Sheet1")
Set ws2 = Excel.Worksheets("Sheet2")
lastRow1 = ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Rows.Count, 1).Row
lastRow2 = ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Rows.Count, 1).Row
' lastRow1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
' lastRow2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row
' Set compareRange = ws1.Range("A1:A" & lastRow1)
' Set toCompare = ws2.Range("A1:A" & lastRow2)
seqNo = 0
For i = 1 To lastRow2
For j = 1 To lastRow1
If ws2.Cells(i, 1).Value <> "" Then
If ws2.Cells(i, 1).Value = ws1.Cells(j, 1).Value Then
seqNo = seqNo + 1
ws2.Cells(i, 1).Value = seqNo
ws1.Cells(j, 1).Value = seqNo
ws2.Cells(i, 1).Interior.Color = vbGreen
ws1.Cells(j, 1).Interior.Color = vbGreen
Exit For
Else
'ws2.Cells(i, 1).Interior.Color = vbWhite
'ws1.Cells(j, 1).Interior.Color = vbWhite
End If
End If
Next j
Next i
End Sub
i have VBA code that check entered dates with the current date and fill the cell in the appropriate color and check if the colomn "F" is not empty it will color the D,E,F columns.
the problem is that i have until now 21 records but the system just color 19 record even so the 2 rows are not empty in the F column.
code:
Private Sub CommandButton1_Click()
Dim i As Long
For i = Range("C5000").End(xlUp).Row To 2 Step -1 'Range upto 5000, chnge this as per your requirment'
If IsEmpty(Cells(i, 3)) Then
Cells(i, 3).Interior.Color = xlNone
ElseIf (VBA.CDate(Cells(i, 3)) - VBA.Date()) < 0 Then
Cells(i, 3).Interior.Color = vbGreen
ElseIf (VBA.CDate(Cells(i, 3)) - VBA.Date()) = 0 Then
Cells(i, 3).Interior.Color = vbYellow
ElseIf (VBA.CDate(Cells(i, 3)) - VBA.Date()) >= 1 And (VBA.CDate(Cells(i, 3)) - VBA.Date()) <= 4 Then
Cells(i, 3).Interior.Color = vbRed
ElseIf (VBA.CDate(Cells(i, 3)) - VBA.Date()) >= 5 And (VBA.CDate(Cells(i, 3)) - VBA.Date()) <= 10 Then
Cells(i, 3).Interior.Color = vbCyan
Else
Cells(i, 3).Interior.ColorIndex = xlNone
End If
' your 2nd criteria to color the entire row if "F" is not empty
If Trim(Range("F" & i).Value) <> "" Then Range("D" & i & ":F" & i).Interior.ColorIndex = 15
Next
End Sub
The ElseIf statements will throw Runtime Error 13 if the cells have a non-date value in them. This is caused by trying to convert a non-date value into a date VBA.CDate(Cells(i, 3))
Private Sub CommandButton1_Click()
Dim i As Long
With Worksheets("Sheet1")
For i = Range("C" & .Rows.Count).End(xlUp).Row To 2 Step -1 'Range upto 5000, chnge this as per your requirment'
If IsDate(Cells(i, 3)) Then
Select Case VBA.CDate(.Cells(i, 3)) - VBA.Date()
Case Is < 0
.Cells(i, 3).Interior.Color = vbGreen
Case Is = 0
.Cells(i, 3).Interior.Color = vbYellow
Case Is <= 4
.Cells(i, 3).Interior.Color = vbRed
Case Is <= 10
.Cells(i, 3).Interior.Color = vbCyan
Case Else
.Cells(i, 3).Interior.ColorIndex = xlNone
End Select
Else
.Cells(i, 3).Interior.ColorIndex = xlNone
End If
' your 2nd criteria to color the entire row if "F" is not empty
If Trim(.Range("F" & i).Value) <> "" Then .Range("D" & i & ":F" & i).Interior.ColorIndex = 15
Next
End With
End Sub
Might be something with your data, it runs properly to me. What kind of data do you have in the F column?
I am trying to write a code that will take one cell and then iterate through another column to find a match, once it has found a match it will then match two other cells in that same row and return the value of a 5th and 6th cell. However, it is not working! any suggestions??
Sub rates()
Dim i As Integer
For i = 2 To 2187
If Cells(i, 1).Value = Cells(i, 11).Value Then
If Cells(i, 2).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
Else
Cells(i, 24) = "No match"
End If
End If
Next i
End Sub
Try fully qualifying your cell objects i.e. sheet1.cells(i,1).value etc or encase within a with statement i.e.
with sheet1
if .cells(i,X) = .cells(i,Y) then
'...etc
end with
I think the default property for a range is "Value" but try putting .Value on to the end of all those Cell lines too... like you have for half of them :)
[EDIT/Addition:]
... failing that, you're not actually searching a whole column at any point: try something like:
Sub rates()
Dim i As Integer
Dim rgSearch As Range
Dim rgMatch As Range
Dim stAddress As String
Dim blMatch As Boolean
With wsSheet
Set rgSearch = .Range(.Cells(x1, y1), .Cells(x2, y2)) ' Replace where appropriate (y = 1 or 11 i guess, x = start and end row)
End With
For i = 2 To 2187
Set rgMatch = rgSearch.Find(wsSheet.Cells(i, y)) ' y = 1 or 11 (opposite of above!)
blMatch = False
If Not rgMatch Is Nothing Then
stAddress = rgMatch.Address
Do Until rgMatch Is Nothing Or rgMatch.Address = stAddress
If rgMatch.Offset(0, y).Value = Cells(i, 12).Value Then
Cells(i, 20) = Cells(i, 1).Value
Cells(i, 21) = Cells(i, 11).Value
Cells(i, 22) = Cells(i, 4).Value
Cells(i, 23) = Cells(i, 16).Value
blMatch = True
Else
End If
Set rgMatch = rgSearch.FindNext(rgMatch)
Loop
End If
If Not blMatch Then
Cells(i, 24) = "No match"
End If
Next i
End Sub
I've made a lot of assumptions in there and there's a few variables you'll have to replace. You could also probably use application.worksheetfunction.match but .find is quicker and more awesome