I'm trying to create a macro that will highlight duplicates in the column where text is being entered.
I have 54 columns and want to highlight duplicates in each column as the text is entered. The scenario is: if "STAPLES" is entered twice in column B then the cells (B3, B22) would be highlighted. I want a macro that can do this for each column, so if "STAPLES" is entered into column E only once nothing should happen.
Using the Conditional Formatting =COUNTIF doesn't necessarily help (due to the workflow of copying columns to new worksheets).
I have this macro already:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rng As Range
Dim cel As Range
'Test for duplicates in a single column
'Duplicates will be highlighted in red
Set Rng = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp))
For Each cel In Rng
If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then
cel.Interior.ColorIndex = 3
End If
Next cel
End Sub
It works ok but is only for one column ("C").
How do I set the range to be the active column?
I have tried to change Rng to
'Set Rng = Range(ActiveCell,ActiveCell.Column.End(xlUp))
but this is obviously wrong.
Any ideas?
Try this one:
Set Rng = Range(Cells(1, Target.Column), Cells(Rows.Count, Target.Column).End(xlUp))
and it's better to use Worksheet_Change event instead Worksheet_SelectionChange.
Btw, there is special CF for duplicates:
UPD:
If you'd like to use VBA, try following code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Dim cel As Range
Dim col As Range
Dim c As Range
Dim firstAddress As String
'Duplicates will be highlighted in red
Target.Interior.ColorIndex = xlNone
For Each col In Target.Columns
Set Rng = Range(Cells(1, col.Column), Cells(Rows.Count, col.Column).End(xlUp))
Debug.Print Rng.Address
For Each cel In col
If WorksheetFunction.CountIf(Rng, cel.Value) > 1 Then
Set c = Rng.Find(What:=cel.Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Interior.ColorIndex = 3
Set c = Rng.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End If
Next
Next col
End Sub
Related
I would like to delete entire rows when cells are blank in column B, but I want to skip some of the cells. I managed to work out a code for the first part, but I want to skip two rows and then let the code delete the next part.
First part is B4:B13 and the next is B16:B27
Try the next code, please. It uses a discontinuous range (as you need) and delete all the rows at the end of the code, at once. Being very fast, even on big ranges:
Sub testDeleteRowsDiscontinuousRange()
Dim sh As Worksheet, lastRow As Long, C As Range, rngDel As Range
Dim rng As Range
Set sh = ActiveSheet ' use here your necessary sheet
lastRow = sh.Range("B" & Rows.count).End(xlUp).Row
Set rng = sh.Range("B4:B13,B16:B27")
For Each C In rng.cells
If C.Value = "" Then
If rngDel Is Nothing Then
Set rngDel = C
Else
Set rngDel = Union(rngDel, C)
End If
End If
Next C
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub
I have a range of values, I want to find the MIN, then highlight the row of this Min value.
Sub worstcase()
Set Rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(Rng)
Debug.Print worstcase
How can I highlight rows based on variable worstcase?
I have my static range, and find the min value, but now I need to highlight the row of the worstcase variable.
Highlight Row With Found Criteria
The code is highlighting each row where the minimum was found. Use Exit For to highlight only the first found.
The Code
Sub worstcase()
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
cell.EntireRow.Interior.ColorIndex = 3 ' Hightlight whole row.
'cell.Interior.ColorIndex = 5 ' Hightlight only cell.
'Exit For ' To highlight only the first found row.
End If
Next
End With
End Sub
EDIT:
Sub worstcase()
Const cFirst As Variant = "H"
Const cLast As Variant = "Q"
Dim worstcase As Double ' Long for whole numbers.
Dim rng As Range
Dim cell As Range
With Worksheets("Sheet1")
Set rng = .Range("H44:H54")
worstcase = Application.WorksheetFunction.Min(rng)
Debug.Print worstcase
For Each cell In rng
If cell.Value = worstcase Then
.Range(.Cells(cell.Row, cFirst), .Cells(cell.Row, cLast)) _
.Interior.ColorIndex = 3 ' Hightlight cells.
'Exit For ' To highlight only the first found cells.
End If
Next
End With
End Sub
You could do it thus.
Won't work though if you have a repeated minimum.
Also you could use conditional formatting and avoid VBA.
Sub worstcase()
Dim Rng As Range, worstcase, i As Long
Set Rng = Range("H44:H54")
With Rng
worstcase = Application.WorksheetFunction.Min(.Cells)
i = Application.Match(worstcase, .Cells, 0)
.Cells(i).EntireRow.Interior.Color = vbRed
End With
End Sub
Create a conditional formatting rule based on the following formula.
=$H44=min($H$44:$H$54)
This VBA will create a CFR for rows 44:54.
With worksheets("sheet1").range("44:54")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=$H44=min($H$44:$H$54)"
.FormatConditions(.FormatConditions.Count).Interior.Color = vbred
End With
I found a procedure to highlight merged cells in an active sheet:
I tried a ActiveCell.EntireRow.Delete statement to delete the row that is currently iterated over.
Sub DeleteRows()
Dim x As Range
For Each x In ActiveSheet.UsedRange
If x.MergeCells Then
x.Interior.ColorIndex = 8
ActiveCell.EntireRow.Delete
End If
Next
End Sub
I don't care about highlighting the merged cells. The goal is to delete any row that has a merged cell.
Find out all merged cell ranges, club them and delete in one go.
Sub DeleteRows()
Dim x As Range
Dim rngDelete As Range
For Each x In ActiveSheet.UsedRange
If x.MergeCells Then
If rngDelete Is Nothing Then
Set rngDelete = x
Else
Set rngDelete = Union(rngDelete, x)
End If
End If
Next
If Not rngDelete Is Nothing Then
rngDelete.EntireRow.Delete
End If
End Sub
When deleting rows, always delete from the bottom up or a) you risk deleting the next cell you want to examine and b) you risk skipping over a row that comes up to take the place of a deleted row.
Sub DeleteRows()
Dim r as long, c as long
with ActiveSheet.UsedRange
'work backwards through the rows
For r = .rows.count to 1 step -1
'work forwards through the columns
For c = 1 to .columns.count
If .cells(r, c).MergeCells Then
'once a merged cell is found, delete then go immediately to the next row
.cells(r, c).EntireRow.Delete
exit for
End If
next c
Next r
end with
End Sub
A quick way to do this is to find all the merged cells then delete them in one go: a good way to do this is to use a range.find using a cells 'format' as merged then combine the found ranges
The following code loops through merged ranges and creates a union then selects the entire rows
Sub SelectMerge()
Dim rng As Range, rngUnion As Range, Test As Range
Dim ws As Worksheet: Set ws = ActiveSheet
With Application.FindFormat
.Clear
.MergeCells = True
End With
With ws.UsedRange
Set rng = .Find("", SearchFormat:=True)
Do
If Not rngUnion Is Nothing Then Set rngUnion = Application.Union(rng, rngUnion)
If rngUnion Is Nothing Then Set rngUnion = rng
If rng Is Nothing Then Exit Do
Set rng = .Find("", After:=rng, SearchFormat:=True)
Loop While Application.Intersect(rng, rngUnion) Is Nothing
End With
If Not rngUnion Is Nothing Then rngUnion.EntireRow.Select 'rngUnion.EntireRow.Delete
End Sub
Using VBA in excel, I am wanting to incorporate the formula located in column "O", shown below, for all B rows that have a value starting at B9. Please reference the image.
=""&D9&" "&I9&" (MK NO. "&B9&")"
This should do what your are looking for.
Sub Pasteformula()
Dim LookupRange As Range
Dim c As Variant
Application.ScreenUpdating = False
Set LookupRange = Range("B9:B500") ' Set range in Column B
For Each c In LookupRange 'Loop through range
If c.Value <> "" Then 'If value in B is empty then
Cells(c.Row, 15).FormulaR1C1 = _
"=""""&RC[-11]&"" ""&RC[-6]&"" (MK NO. ""&RC[-13]&"")""" 'Apply formula
End If
Next c
Application.ScreenUpdating = True
End Sub
Set the range and enter the formula, then change the range to values.
Sub Button1_Click()
Dim rng As Range
Set rng = Range("O9:O" & Cells(Rows.Count, "B").End(xlUp).Row)
rng.Formula = "=CONCATENATE(D9,"" "",I9,"" (MK NO. "",B9,"")"")"
rng.Value = rng.Value
End Sub
from your narrative I get that you already have the proper formula in O9, hence you could use AutoFill() method of Range object:
Range("O9").AutoFill Range("B9", Cells(Rows.Count, "B").End(xlUp)).Offset(,13)
I'm trying to use VBA in a macro to search for a text string and delete the contents of the column. I previously found this on the website and would like to change it to search columns and delete the text "QA1" while retaining the columns. I hope this makes sense.
LastRow = Cells(Columns.Count, "D").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("D" & i).Value = "D" Then
Range("D" & i).EntireColumn.Delete
End If
Next i
You want to clear the contents of the whole column if one cell contains QA1?
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Columns(4)
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
.ClearContents
End If
End With
End Sub
If you want to just clear each instance of QA1 in column D:
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Columns(4)
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
Do
rCell.ClearContents
Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing
End If
End With
End Sub
Can it be written to look through the entire worksheet and delete QA1
where ever it is found?
All instances of QA1 on sheet:
Sub Test()
Dim rCell As Range
With ThisWorkbook.Worksheets("Sheet1").Cells
Set rCell = .Find("QA1", LookIn:=xlValues)
If Not rCell Is Nothing Then
Do
rCell.ClearContents
Set rCell = .FindNext(rCell)
Loop While Not rCell Is Nothing
End If
End With
End Sub
Edit: Add LookAt:=xlWhole to the Find arguments so it doesn't delete cells containing QA1 and other text (e.g. QA11 or Some text QA1)
This code goes through columns in a specified row and removes the "QA1" if found
Dim LastColumn As Integer
Dim RowNumber As Integer
Dim i As Integer
LastColumn = UsedRange.SpecialCells(xlCellTypeLastCell).Column
RowNumber = 1 'Adjust to your needs
For i = 1 To LastColumn Step 1
Cells(RowNumber, i).Value = Replace(Cells(RowNumber, i).Value, "QA1", "")
Next i
Loops through the used range of the active worksheet, and removes the selected text.
Sub RemoveText()
Dim c As Range
Dim removeStr As String
removeStr = InputBox("Please enter the text to remove")
For Each c In ActiveSheet.UsedRange
If c.Value = removeStr Then c.Delete
Next c
End Sub