I have cells to look for in sheet4 and the lookup table is in sheet2 Range("A16:B25"). When I run this code it is giving me a mismatch error. Why is it doing this?
Dim i As Integer
Dim lrow As Long
Dim x As Integer
Sheet4.Activate
lrow = Sheet4.Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lrow
Cells(i, 1).Activate
x = Application.VLookup(ActiveCell.Offset(0, 0).Value, Worksheets(2).Range("A16:B25"), 2, False)
If x <> Cells(i, 2).Value Then
Cells(i, 2).Interior.Color = RGB(255, 0, 0)
Else
End If
Next i
1: You do not need to activate anything unless it is absolutely necessary. Use explicit references (workbook.worksheet.cell or .range)
2: You need to check if your vlookup is returning an error.
3: ActiveCell.Offset(0, 0).Value is just the activecell since you have no offset.
Try to get this into your code, you may have to adjust things for your specific use.
sub lookup_color()
Dim i As Integer
Dim lrow As Long
Dim vReturnVal As Variant
lrow = Sheet4.Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lrow
vReturnVal = Application.VLookup(Sheet4.Cells(i, 1).Value, Worksheets(2).Range("A16:B25"), 2, False)
If Not IsError(vReturnVal) Then
If vReturnVa <> Sheet4.Cells(i, 2).Value Then
Sheet4.Cells(i, 2).Interior.Color = RGB(255, 0, 0)
End If
End iF
Next i
End sub
Related
I want to delete entire row when all 3 numeric values in cells in columns G,H,I are equal. I wrote a vba code and it does not delete nothing. can Someone advise?
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
Set rng = Range("G2", Range("G2").End(xlDown))
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = 2 To NumRows
Cells(i, 7).Select
If Cells(i, 7).Value = Cells(i, 8).Value = Cells(i, 9).Value Then
EntireRow.Delete
Else
Selection.Offset(1, 0).Select
End If
Next i
End Sub
Try this code. When deleting rows, always start from last row and work towards first one. That way you are sure you wont skip any row.
Sub remove_dup()
Dim rng As Range
Dim NumRows As Long
Dim i As Long
NumRows = Range("G2", Range("G2").End(xlDown)).Rows.Count
For i = NumRows + 1 To 2 Step -1
If Cells(i, 7).Value = Cells(i, 8).Value And Cells(i, 7).Value = Cells(i, 9).Value Then
Cells(i, 7).EntireRow.Delete
Else
End If
Next i
End Sub
Remember when you delete rows, all you need to loop in reverse order.
Please give this a try...
Sub remove_dup()
Dim NumRows As Long
Dim i As Long
NumRows = Cells(Rows.Count, "G").End(xlUp).Row
For i = NumRows To 2 Step -1
If Application.CountIf(Range(Cells(i, 7), Cells(i, 9)), Cells(i, 7)) = 3 Then
Rows(i).Delete
End If
Next i
End Sub
You can delete all rows together using UNION. Try this
Sub remove_dup()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim cel As Range, rng As Range
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet3 to your data range
With ws
lastRow = .Cells(.Rows.Count, "G").End(xlUp).Row 'last row with data in Column G
For i = lastRow To 2 Step -1 'loop from bottom to top
If .Range("G" & i).Value = .Range("H" & i).Value And .Range("G" & i).Value = .Range("I" & i).Value Then
If rng Is Nothing Then 'put cell in a range
Set rng = .Range("G" & i)
Else
Set rng = Union(rng, .Range("G" & i))
End If
End If
Next i
End With
rng.EntireRow.Delete 'delete all rows together
End Sub
What I'm trying to do is remove any rows where a cell value in a specific column matches what is defined to remove. After that is done re-sequence the value in another column by group.
Using the example below:
I want to look at column B and remove any rows that have a value of A or C. Then I want to basically renumber after the dot (.) in column A to reset itself.
Before Macro Code Fig. 1
After value A and C are removed Fig. 2
Final list after column A is renumbered Fig. 3
I figured out how to remove the rows using this code, but stuck on what to do next:
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long
For RowToTest = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" _
Then _
Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
End Sub
This will be easier to do looping from the top down (using step 1 instead of step -1). I've tried to stay true to your original coding and made this:
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long
Dim startRow As Long
Dim i As Integer
startRow = 2
'Clear the rows that have "A" or "C" in column B
For RowToTest = Cells(Rows.Count, 1).End(xlUp).Row to startRow To Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" _
Then _
Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
'If the left 3 characters of the cell above it are the same,_
'then increment the renumbering scheme
For RowToTest = startRow To Cells(Rows.Count, 1).End(xlUp).Row
If Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), "\")) = Left(Cells(RowToTest, 1).Offset(-1, 0).Value, InStr(1, Cells(RowToTest, 1), "\")) Then
i = i + 1
Cells(RowToTest, 1).Value = Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), ".")) & i
Else
i = 0
Cells(RowToTest, 1).Value = Left(Cells(RowToTest, 1).Value, InStr(1, Cells(RowToTest, 1), ".")) & i
End If
Next RowToTest
End Sub
EDIT: I've updated it to compare all of the string before the backslash and compare using that.
EDIT++: It has been brought to my attention that when deleting rows it is better to work from the bottom up (step -1) to ensure every row is accounted for. I've re-implemented the original steps in the first code.
Admittedly, this isn't probably the most efficient, but it should work.
Sub DeleteRowBasedOnCriteriga()
Dim RowToTest As Long, i As Long
Application.ScreenUpdating = False
For RowToTest = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
With Cells(RowToTest, 2)
If .Value = "A" Or .Value = "C" Then Rows(RowToTest).EntireRow.Delete
End With
Next RowToTest
Dim totalRows As Long
totalRows = Cells(Rows.Count, 1).End(xlUp).Row
Dim curCelTxt As String, aboveCelTxt As String
For i = totalRows To i Step -1
If i = 1 Then Exit For
curCelTxt = Left(Cells(i, 1), WorksheetFunction.Search("\", Cells(i, 1)))
aboveCelTxt = Left(Cells(i - 1, 1), WorksheetFunction.Search("\", Cells(i - 1, 1)))
If curCelTxt = aboveCelTxt Then
Cells(i, 1).Value = ""
Else
Cells(i, 1).Value = WorksheetFunction.Substitute(Cells(i, 1), Right(Cells(i, 1), Len(Cells(i, 1)) - WorksheetFunction.Search(".", Cells(i, 1))), "0")
End If
Next i
Dim rng As Range, cel As Range
Dim tempLastRow As Long
Set rng = Range("A1:A" & Cells(Rows.Count, 2).End(xlUp).Row)
For Each cel In rng
If cel.Offset(1, 0).Value = "" Then
tempLastRow = cel.End(xlDown).Offset(-1, 0).Row
If tempLastRow = Rows.Count - 1 Then
tempLastRow = Cells(Rows.Count, 2).End(xlUp).Row
cel.AutoFill Destination:=Range(cel, Cells(tempLastRow, 1))
Exit For
Else
cel.AutoFill Destination:=Range(cel, Cells(tempLastRow, 1))
End If
End If
Next cel
Application.ScreenUpdating = True
End Sub
Mainly, I discovered that you can use AutoFill to fix the last number in the string. Meaning if you AutoFill this text, CAT\Definitions.0 down, you get the number updating as you drag/fill.
I am new to VBA and have a small doubt. I was trying to convert certain values from a particular cell from hexadecimal to decimal, I have a small difficulty in that. In that cell there are lot of blank cells. For example the first 5 rows are blank then I have a hex value again 3 blank rows and a hex value. I am not able to loop through due to the blank cell. Please if somebody could help. Below is the code I wrote.
Sub Conversion()
Dim j As Integer
Dim LR As Integer
LR = Range("B" & Rows.Count).End(xlUp).Row
For j = 3 To LR
If Cells(j, 2).value = "" Then Cells(j, 3).value = "#N/A" Else
Cells(j, 3).value = CLng("&H" & Cells(j, 2).value)
Next
End Sub
I am getting Mismatch error with this code
You kinda forgot End If at the end. I have organized your code little bit and add End If and seems it works.
Sub Conversion()
Dim j As Integer
Dim LR As Integer
LR = Range("B" & Rows.Count).End(xlUp).Row
MsgBox Range("B" & Rows.Count).End(xlUp).Row
For j = 3 To LR
If Cells(j, 2).Value = "" Then
Cells(j, 3).Value = "#N/A"
Else
Cells(j, 3).Value = CLng("&H" & Cells(j, 2).Value)
End If
Next
End Sub
CLng is not working, as it is giving error in that as far as i read and understood you can use the below code, YOu can use Format instead of the CLNG command in ur code
Sub Conversion()
Dim j As Integer
Dim LR As Integer
LR = Range("A" & Rows.Count).End(xlUp).Row
For j = 1 To LR
If Cells(j, 1).Value = "" Then
Cells(j, 3).Value = "#N/A"
Else
Cells(j, 3).Value = "&H" & Format(Cells(j, 1).Value, "0")
End If
Next
End Sub
Try this:
For j = 3 To LR
If Cells(j, 2).Value = "" Then
Cells(j, 3).Value = "#N/A"
Else
Cells(j, 3).Value = CLng("&H" & Cells(j, 2).Value)
End If
For ignoring errors:
On Error Resume Next
here is one that uses a ternary function
Sub Conversion()
Dim sht As Worksheet
Set sht = ActiveWorkbook.Sheets("Sheet3")
Dim LR As Range
Set LR = sht.Range("B1", sht.Range("B" & sht.Rows.Count).End(xlUp))
Dim cel As Range
For Each cel In LR
cel.Offset(0, 1).Value = IIf(cel.Value = "", "#N/A", CLng("&H" & cel.Value))
Next cel
End Sub
I use the below code to color the cells in column K and Z that match the criteria; but it colors all cells between K and Z. To fix, I use the last line of code to remove the color in columns L thru Y. Is there a way to modify the line of code that starts with "Range" to only color cells K and Z that match the criteria?
Sub ColrCls()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("K" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "Non Sen" And .Cells(i, 26).Value = "N/A" Then
Range(.Cells(i, 11), .Cells(i, 26)).Interior.ColorIndex = 6
End If
Next i
Columns("L:Y").Interior.ColorIndex = xlNone
End With
End Sub
You are specifying the Range.Parent property in your With ... End With statement but ignoring it when it is most important¹.
Sub ColrCls()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("K" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "Non Sen" And .Cells(i, 26).Value = "N/A" Then
.Range("K" & i & ", Z" & i).Interior.ColorIndex = 6
Else
.Range("K" & i & ", Z" & i).Interior.Pattern = xlNone
End If
Next i
End With
End Sub
A Range object to Union discontiguous cells could be one of the following.
.Range("K5, Z5")
Union(.Cells(5, "K"), .Cells(5, "Z"))
In the example above, I've concatenated together a string like the first of these two examples.
¹ See Is the . in .Range necessary when defined by .Cells? for an earnest discussion on this subject.
You could replace
Range(.Cells(i, 11), .Cells(i, 26)).Interior.ColorIndex = 6
with
.Cells(i, 11).Interior.ColorIndex = 6
.Cells(i, 26).Interior.ColorIndex = 6
Why isnt this text Compare working? I'm trying to compare 2 different ranges from different sheets.
Is there a good simple way of doing this?
Sub selecttest()
Text3 = Sheets("Input DATA").Range(Cells(2, 2), Cells(2, Columns.Count).End(xlToLeft))
Text4 = Sheets("SAP Output DATA").Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp))
If StrComp(Text3, Text4, vbTextCompare) = 0 Then
Else
Cells(Cell.Row, "A").Interior.ColorIndex = 26
Cells(Cell.Row, "B").Interior.ColorIndex = 26
Cells(Cell.Row, "C").Interior.ColorIndex = 26
Cells(Cell.Row, "D").Interior.ColorIndex = 26
End If
End Sub
Is there something that im doing incorrectly?
Also tried this with no errors but it wont solve:
Sub comprangetest()
With ThisWorkbook.Sheets("Input DATA")
Text3 = Range(Cells(2, 2), Cells(2, Columns.Count).End(xlToLeft)).Select
End With
With ThisWorkbook.Sheets("SAP Output DATA")
Text4 = Sheets("SAP Output DATA").Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp)).Select
End With
'Text3 = Sheets("Input DATA").Range(Cells(2, 2), Cells(2, Columns.Count).End(xlToLeft))
'Text4 = Sheets("SAP Output DATA").Range(Cells(3, 1), Cells(Rows.Count, 1).End(xlUp))
If StrComp(Text3, Text4, vbTextCompare) = 0 Then
Else
ActiveSheet.Cells(Cell.Row, "A").Interior.ColorIndex = 26
ActiveSheet.Cells(Cell.Row, "B").Interior.ColorIndex = 26
ActiveSheet.Cells(Cell.Row, "C").Interior.ColorIndex = 26
ActiveSheet.Cells(Cell.Row, "D").Interior.ColorIndex = 26
End If
End Sub
Am i using the correct method?
Instead of comparing from different sheets, i just brought the range over to the current sheet and made it a requirement to use a selection before the compare initiates. Since the source range is on a row, i used k as the integer for where the source is. The source always changes and is always above the selection. so that line is used for the compare. Of coarse i can probably now even go further and create a selection range from another sheet. But this works for me now. I hope i saved some time for other people struggling with this as i was.
Sub CompareRanges()
application.ScreenUpdating = False
Dim Report As Worksheet
Dim i As Integer, j As Integer, k As Integer
Dim lastrow As Integer
Dim LastColumn As Integer
Dim sht As Worksheet
Dim cell As Range
Dim x As Long, y As Long
Set sht = ThisWorkbook.Sheets("SAP Output DATA")
lastrow = sht.UsedRange.Rows.Count
LastColumn = sht.UsedRange.Columns.Count
'If Selection Is Nothing Then
'MsgBox "nothing selected, please select range."
'Else
'x is the first row number of selection, y is the last.
x = Selection.Rows(1).row
y = Selection.Rows.Count + x - 1
'MsgBox x & " " & y
'give row number of cell above selection.
k = Selection.Rows(1).Offset(-1, 0).row
'MsgBox k
For i = x To y 'lastrow
'For i = 3 To lastrow 'lastrow
For j = 5 To LastColumn
If sht.Cells(i, 1).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
'sht.cell (2, j) "k is the variable for where is the source."
If InStr(1, sht.Cells(k, j).Value, sht.Cells(i, 1).Value, vbTextCompare) > 0 Then
sht.Cells(i, 1).Interior.Color = RGB(255, 255, 255) 'White background
sht.Cells(i, 1).Font.Color = RGB(0, 0, 0) 'Black font color
Exit For
Else
sht.Cells(i, 1).Interior.Color = RGB(156, 0, 6) 'Dark red background
sht.Cells(i, 1).Font.Color = RGB(255, 199, 206) 'Light red font color
End If
End If
Next j
Next i
'End If
application.ScreenUpdating = True
End Sub