Remove Duplicated based on the adjacent cell values, with help of VBA
ID|Status
1234|Not Started - Need to be deleted
1234|Completed
3456|Completed
3456|Completed - Need to be deleted
Given your sample data all you have to do is sort by the second column in a ascending order then use Remove Duplicates.
Option Explicit
Sub sortNdedupe()
With Worksheets("sheet4")
With .Range(.Cells(1, "A"), .Cells(.Rows.Count, "B").End(xlUp))
.Cells.Sort Key1:=.Columns(2), Order1:=xlAscending, _
Header:=xlYes
.RemoveDuplicates Columns:=1, Header:=xlYes
End With
End With
End Sub
Select which of the two methods do you prefer and try:
Sub Removeduplicates()
Dim Lastrow As Long
With Worksheets("sheet1")
Lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Remove based on based on ID
With .Range("A1" & ":B" & Lastrow)
.Removeduplicates Columns:=1, Header:=xlYes
End With
'Remove based on ID and Status
With .Range("A1" & ":B" & Lastrow)
.Removeduplicates Columns:=Array(1, 2), Header:=xlYes
End With
End With
End Sub
Related
I have a set of code to advanced filter Dataset's Column F and H if certain criteria are met, after that the filtered data under Column F to I will be copied to another worksheet's next empty row, in sequence (F & G first, then H & I).
With Worksheets("Sheet3")
.Range("A:K").AutoFilter Field:=6, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
.Range("F2:G" & .Cells(.Rows.Count, "F").End(xlUp).Row).Copy
Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
.Range("A:K").AutoFilter Field:=8, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
.Range("H2:I" & .Cells(.Rows.Count, "H").End(xlUp).Row).Copy
Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End With
*Note: There are headers in first row of this Dataset.
This code works flawlessly when they are values after filtering. When there isn't any values after filtering, VBA does not stop copying, instead it copies the header of Column F, G, H and I, which is not what I wanted.
The outcome should be - Nothing (including header) is copied to Sheet 4 if there isn't any values after filtering. How can I achieve this?
Please, replace the code you show:
With Worksheets("Sheet3")
.Range("A:K").AutoFilter Field:=6, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
.Range("F2:G" & .Cells(.Rows.Count, "F").End(xlUp).Row).Copy
Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
.Range("A:K").AutoFilter Field:=8, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
.Range("H2:I" & .Cells(.Rows.Count, "H").End(xlUp).Row).Copy
Sheets("Sheet4").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End With
with this one, which checks if there are visible cells in the range to be copied (except the header):
Dim rngFG As Range, rngHI As Range, lastRow As Long
With Worksheets("Sheet3")
.Range("A:K").AutoFilter field:=6, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
lastRow = .cells(.rows.count, "F").End(xlUp).row
On Error Resume Next
Set rngFG = .Range("F2:G" & lastRow).Resize(lastRow - 1).Offset(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngFG Is Nothing Then 'the range is nothing if no visible cell in it
.Range("F2:G" & lastRow).Copy
Sheets("Sheet4").cells(rows.count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
.Range("A:K").AutoFilter field:=8, Criteria:=">=10000000", Operator:=xlAnd, Criteria2:="<=99999999"
astRow = .cells(.rows.count, "H").End(xlUp).row
On Error Resume Next
Set rngHI = .Range("H2:I" & astRow).Resize(lastRow - 1).Offset(1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngFG Is Nothing Then
.Range("H2:I" & lastRow).Copy
Sheets("Sheet4").cells(rows.count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End With
It assumes that the header (to be excepted in checking) is on the second row.
Not tested, but it should work. Except the case of a typo somewhere in the code, I think. That's why please, send some feedback after testing it. If something does not work as you need, do not hesitate to explain what and in which circumstances...
Part 1:
Please help to advise where did it went wrong. Would like to sort for column E via descending order with header
Sub SortRows()
Dim destSht As Worksheet
Set destSht = ThisWorkbook.Worksheets("Account Level")
destSht.Sort.SortFields.Clear
Range("E2", destSht.Cells(destSht.Rows.Count, "E").End(xlUp)).Sort Key1:=Range("E2"),
Header:=xlYes, _
Order1:=xlDescending
End Sub
Part 2:
How should I input the vba code in a way which it could dynamically filter column C based on descending values?
Maybe
destSht.Range("E2", destSht.Cells(destSht.Rows.Count, "E").End(xlUp)).Sort Key1:=destSht.Range("E2"),
Header:=xlYes, _
Order1:=xlDescending
Based on latest comments 12-May-2022
Sub sortRows()
With Worksheets("Account Level")
.sort.SortFields.Clear
.Cells(1, 1).CurrentRegion.sort key1:=.Cells(2, 4), order1:=xlDescending, Header:=xlYes
.Cells(1, 1).CurrentRegion.AutoFilter
End With
End Sub
Thank you in advance and sorry for the bad english!
I want
fix100-->current column & last row nummber?
Cells(100, ActiveCell.Column))--->Cells(???, ActiveCell.Column))
Sub ExcelVBA_CurrentValuecu_Filter()
ActiveSheet.Range(Cells(1, ActiveCell.Column), Cells(100, ActiveCell.Column)).AutoFilter Field:=1, Criteria1:=ActiveCell.Value
End Sub
Try this code:
Sub ExcelVBA_CurrentValuecu_Filter()
With ThisWorkbook.ActiveSheet
.Range(.Cells(1, ActiveCell.Column), .Cells(.Rows.Count, ActiveCell.Column).End(xlUp)). _
AutoFilter Field:=1, Criteria1:=ActiveCell.Value
End With
End Sub
The statement .Cells(.Rows.Count, ActiveCell.Column).End(xlUp) will find the last cell in your column that has data in it. I used a With block to properly qualify all the ranges you're using in your code. That's why there's a dot . in front of .Cells. This is the same as always writing ActiveSheet.Cells.
I have a table that can contain any number of rows:
As I said it can contain 1 or ā rows.
I want to sort range A3:Dā by the Date cell that is in column B.
How can I do it?
The problem is that I don't know how to select from A3 to the last row.
I think that looping to the last row is not a correct method.
I have got this so far it sorts looks like correct, but the range is hard-coded. How do I get rid of the hard-coding of the range?
Range("A3:D8").Sort key1:=Range("B3:B8"), _
order1:=xlAscending, Header:=xlNo
Try this code:
Dim lastrow As Long
lastrow = Cells(Rows.Count, 2).End(xlUp).Row
Range("A3:D" & lastrow).Sort key1:=Range("B3:B" & lastrow), _
order1:=xlAscending, Header:=xlNo
Or this:
Range("A2", Range("D" & Rows.Count).End(xlUp).Address).Sort Key1:=[b3], _
Order1:=xlAscending, Header:=xlYes
You can sort any range in a very dynamic way by using the SortRange and GetCurrentRegionStartingGivenCell function in Xatocode as follows:
' First you may define a worksheet level named range in cell "A2" and name it as rngData
Sub SortExample()
Dim rngData As Range ' Range to sort
Set rngData = GetCurrentRegionStartingGivenCell(shtData.Range("rngData"))
Call SortRange(rngData, True, 2, xlAscending, 3, xlDescending)
End Sub
You can read the complete article here
If the starting cell of the range and of the key is static, the solution can be very simple:
Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort key1:=Range("B3", Range("B3").End(xlDown)), _
order1:=xlAscending, Header:=xlNo
I have a few thousand columns of data and I need to remove the duplicate records in each individual column before looking at the next column. I have this code that was created when I recorded the Macro, but it's only doing the columns that I specifically entered, and I want it to continue looking at future columns until there is no more data.
Sub DUPLICATE()
'
' DUPLICATE Macro
'
' Keyboard Shortcut: Ctrl+d
'
ActiveSheet.Range("$T$1:$T$12").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("U:U").Select
ActiveSheet.Range("$U$1:$U$12").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("V:V").Select
ActiveSheet.Range("$V$1:$V$12").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("W:W").Select
ActiveSheet.Range("$W$1:$W$12").RemoveDuplicates Columns:=1, Header:=xlNo
Columns("X:X").Select
ActiveSheet.Range("$X$1:$X$12").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
This should do the trick:
Sub DeleteDublicates()
Dim i As Integer
For i = 1 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column Step 1
ActiveSheet.Range(Cells(1, i), Cells(Cells(Rows.Count, i).End(xlUp).row, i)).RemoveDuplicates Columns:=1, Header:=xlNo
Next i
End Sub