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
Related
Im looking for a solution to get the result as in the screenshot. If theres at least 3 blanks or more then change second cell from first blank on first column to "x" :
Sub findThreeEmptyCells()
Dim lastRow As Long, i As Long
Dim firstEmptyCell As Range
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
For i = 10 To lastRow
If Cells(i + 1, 5).Value = "" And Cells(i + 2, 5).Value = "" Then
Set firstEmptyCell = Cells(i + 2, 1)
Exit For
End If
Next i
If firstEmptyCell Is Nothing Then
MsgBox ("There are no two empty cells in a row")
Exit Sub
End If
firstEmptyCell.Value = "x"
End Sub
Sub findThreeEmptyCells()
Dim lastRow As Long, i As Long
Dim firstEmptyCell As Range
lastRow = Cells(Rows.Count, 5).End(xlUp).Row ' Assuming your column A has the most data or is the row you want to check.
For i = 10 To lastRow
If Cells(i + 1, 5).Value = "" And Cells(i + 2, 5).Value = "" And Cells(i + 3, 5).Value = "" Then
Set firstEmptyCell = Cells(i + 2, 1)
Exit For
End If
Next i
If firstEmptyCell Is Nothing Then
MsgBox ("There are no two empty cells in a row")
Exit Sub
End If
firstEmptyCell.Value = "x"
End Sub
My VBA script errors when I try to insert data from Sheet1 into Sheet2. Script code delivers only "Case 2-3" ROW numbers, first "Case" does not input into Sheet 2. Wondering what else should be included in VBA script to finalize processes?
My VBA Script:
Sub CopyFromSheet1()
Dim i As Long
For i = 1 To Sheet1.Cells(Sheet1.Rows.Count, 6).End(xlUp).Row ' Last Cell of Column F
Select Case CStr(Sheet1.Cells(i, 3).Value) ' Looks at the Value in Column C
Case "Due From"
Sheet2.Cells(22, 3).Value = Sheet1.Cells(i, 6).Value
Case "TOTAL1"
Sheet2.Cells(23, 3).Value = Sheet1.Cells(i, 6).Value
Case "TOTAL2"
Sheet2.Cells(24, 3).Value = Sheet1.Cells(i, 6).Value
End Select
Next i
End Sub
What about this: Do you everything your doing, but just for Column C. And then Do it all again for column D?
Sub CopyFromSheet1()
Dim i As Long
Dim col as Long
for col = 3 to 4
For i = 1 To Sheet1.Cells(Sheet1.Rows.Count, 6).End(xlUp).Row ' Last Cell of Column F
Select Case CStr(Sheet1.Cells(i, col).Value)
Case "Due From"
Sheet2.Cells(22, 3).Value = Sheet1.Cells(i, 6).Value
Case "TOTAL1"
Sheet2.Cells(23, 3).Value = Sheet1.Cells(i, 6).Value
Case "TOTAL2"
Sheet2.Cells(24, 3).Value = Sheet1.Cells(i, 6).Value
End Select
Next i
next col
End Sub
I am trying to make a VBA scrip that check all cells between B2 and B60 for the text "Ja" that's yes in Norwegian.
How can I make this a little bit simpler that making a "if" command for each cell?
I want it to, if the cell contains "ja"(yes) then write to colum D and the same number.
ie. B1,2,3,4,5 cotains "ja", I need it to take the previous cell value in D1.2,3,4,5 and add another digit to it +1.
If nothing is found in B(ie.false) it needs to write "NEI" in the current cell, and if "NEI" (no) is found in that cell it adds +1 to colum E
Sub Macro2()
Dim celltxt As String
Dim a As Variant
If IsEmpty(Range("B2").Value) = True Then
Cells(2, 2).Value = "NEI"
End If
celltxt = ActiveSheet.Range("B2").Text
If InStr(1, celltxt, "ja") Then
a = Cells(2, 1).Value
'write to cell
Cells(2, 4).Value = Cells(2, 4) + 1
Else
'antall Cw'er vedkommende IKKE har deltatt på
Cells(2, 5).Value = Cells(2, 5) + 1
End If
If IsEmpty(Range("B3").Value) = True Then
Cells(3, 2).Value = "NEI"
End If
celltxt = ActiveSheet.Range("B3").Text
If InStr(1, celltxt, "ja") Then
a = Cells(3, 1).Value
'write to cell
Cells(3, 4).Value = Cells(3, 4) + 1
Else
'antall Cw'er vedkommende IKKE har deltatt på
Cells(3, 5).Value = Cells(3, 5) + 1
End If
End Sub
Sub slettingALL()
Range("D2:E55").Select
Selection.ClearContents
End Sub
Sub slettingdeltakelse()
Range("B2:B60").Select
Selection.ClearContents
End Sub
The following code uses a For Each loop and an IF THEN ELSE statement to check for the value "JA" in the range B2:B60.
If it finds "JA", it looks two columns to the right from the current i location, and adds "+1" to the value above it. If it finds nothing, it writes "NEI" to the current i location, and then moves three columns to the right and adds +1 to the value above it.
Sub Macro2()
For Each i In Range(Cells(2, 2), Cells(60, 2))
If i.Value = "JA" Then
i.Offset(0, 2).Value = i.Offset(-1, 2).Value + 1
Else
i.Value = "NEI"
i.Offset(0, 3).Value = i.Offset(-1, 3).Value + 1
End If
Next i
End Sub
Please let me know if this code does not work for your purpose.
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
Is there a way in vba to fill a range until a certain value is reached?
For example, I want to fill column A with dates starting from the value in cell B1 (Let’s say 1/1/2014) till it reaches the value in cell C1 (Let’s say 1/15/2014) stepping one day.
Is this possible please?
Thank u.
Here is my proposition, just put the dates in B1 and C1 cells and run "Dates" macro.
Sub Dates()
Dim startdate As Date
Dim enddate As Date
Dim row As Double
startdate = Range("B1").Value
enddate = Range("C1").Value
row = 0
Range("A1").Select
Do Until DateAdd("d", 1, startdate) = enddate + 1
ActiveCell.Offset(row, 0).Value = DateAdd("d", 1, startdate)
startdate = startdate + 1
row = row + 1
Loop
End Sub
How about:
Sub DateFiller()
For i = 2 To Rows.Count
Cells(i, 1).Value = Cells(i - 1, 1).Value + 1
If Cells(i, 1).Value = Cells(1, 2).Value Then Exit Sub
Next i
End Sub
EDIT#1:
this version matches the request:
Sub DateFiller()
Cells(1, 1).Value = Cells(1, 2).Value
For i = 2 To Rows.Count
Cells(i, 1).Value = Cells(i - 1, 1).Value + 1
If Cells(i, 1).Value = Cells(1, 3).Value Then Exit Sub
Next i
End Sub