Delete all rows if duplicate in excel - VBA - vba

I need to remove all rows without leaving any unique record. If duplicate exists delete all matching rows. Criteria is column C if any duplicate record exists in column C then delete entire row (including unique).
Below given code is working but leaving the unique row Even I don't want that.
Code:
Sub DDup()
Sheets("MobileRecords").Activate
With ActiveSheet
Set Rng = Range("A1", Range("C1").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(3, 3), Header:=xlYes
End With
End Sub

I like the code from Jeeped, but it isn't the best readable one. Therefore, here is another solution.
Sub remDup()
Dim rng As Range, dupRng As Range, lastrow As Long, ws As Worksheet
Dim col As Long, offset As Long, found As Boolean
'Disable all the stuff that is slowing down
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Define your worksheet here
Set ws = Worksheets(1)
'Define your column and row offset here
col = 3
offset = 0
'Find first empty row
Set rng = ws.Cells(offset + 1, col)
lastrow = rng.EntireColumn.Find( _
What:="", After:=ws.Cells(offset + 1, col)).Row - 1
'Loop through list
While (rng.Row < lastrow)
Do
Set dupRng = ws.Range(ws.Cells(rng.Row + 1, col), ws.Cells(lastrow, col)).Find( _
What:=rng, LookAt:=xlWhole)
If (Not (dupRng Is Nothing)) Then
dupRng.EntireRow.Delete
lastrow = lastrow - 1
found = True
If (lastrow = rng.Row) Then Exit Do
Else
Exit Do
End If
Loop
Set rng = rng.offset(1, 0)
'Delete current row
If (found) Then
rng.offset(-1, 0).EntireRow.Delete
lastrow = lastrow - 1
End If
found = False
Wend
'Enable stuff again
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
It works with more than one duplicate and you can define an row offset, which defines how much rows you ignore at the beginning of the column.

I like to try these without any declared variables. It is good practise for keeping your cell / worksheet / workbook hierarchy together.
Sub dupeNuke()
With Worksheets("Sheet1") '<~~ you should know what worksheet you are supposed to be on
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, 1).Offset(1, 2)
With .FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=COUNTIF(C:C, C2)>1"
End With
With .FormatConditions(.FormatConditions.Count)
.Interior.Color = vbRed
End With
End With
With .Resize(.Rows.Count, 1).Offset(0, 2)
.AutoFilter Field:=1, Criteria1:=vbRed, Operator:=xlFilterCellColor
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, Cells)) Then
.EntireRow.Delete
End If
End With
End With
With .Resize(.Rows.Count - 1, 1).Offset(1, 2)
With .FormatConditions
.Delete
End With
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
Obviously, this is heavily reliant on the With ... End With statement. An underrated / underused method in my estimation.

Related

I want to filter all the value except values in Array

I want to filter all the values except value in Array i.e. "B400", "A200", "C300".
I tried following code, none of the code is working
Dim rDataRange as Range
set rDataRange = Range("A1:P1000")
rDataRange.AutoFilter Field:=11, Criteria1:="<>" & Array("B400", "A200", "C300"), Operator:=xlFilterValues
rDataRange.AutoFilter Field:=11, Criteria1:=Array("<>B400", "<>A200", "<>C300"), Operator:=xlFilterValues
Please help me
Modified for your situation:
Option Explicit
Sub AutoFilterWorkaround()
Dim sht As Worksheet
Dim filterarr As Variant, tofindarr As Variant
Dim lastrow As Long, i As Long, j As Long, k As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'List the parts of the words you need to find here
tofindarr = Array("B400", "A200", "C300")
ReDim filterarr(0 To 0)
j = 0
For i = 2 To lastrow
If sht.Cells(i, 11).Value <> tofindarr(0) And _
sht.Cells(i, 11).Value <> tofindarr(1) And _
sht.Cells(i, 11).Value <> tofindarr(2) Then
filterarr(j) = sht.Cells(i, 11).Value
j = j + 1
ReDim Preserve filterarr(0 To j)
End If
Next i
'Filter on array
sht.Range("$A$1:$P$" & lastrow).AutoFilter Field:=11, Criteria1:=Array(filterarr), Operator:=xlFilterValues
End Sub
There is an easier way to accomplish this then using a filter.
Dim lRow As Long
With ThisWorkbook.Sheets(1)
lRow = .Range("K" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
If .Cells(i, 11).Value = "A200" Or .Cells(i, 11).Value = "B400" Or .Cells(i, 11).Value = "C300" Then
.Cells(i, 11).EntireRow.Hidden = True
End If
Next i
End With
you could still use AutoFilter() in a sort of reverse mode:
Dim myRng As Range ' helper range variable
With Range("A1:P1000") ' reference wanted range to filter, header row included
.AutoFilter field:=11, Criteria1:=Array("B400", "A200", "C300"), Operator:=xlFilterValues ' filter on "not wanted" values
If Application.Subtotal(103, .Resize(, 1)) > 1 Then ' if any filtered cell other than header row
Set myRng = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ' temporarily set 'myRng' to referenced range "not wanted" rows
.Parent.AutoFilterMode = False ' remove filters and show all rows
myRng.EntireRow.Hidden = True ' hide referenced range "not wanted" rows, leaving "wanted" rows only visible
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ' reference referenced range "wanted" rows
.Select
' do what you want with "wanted" rows
End With
.EntireRow.Hidden = False ' unhide all referenced range rows
Else
.Parent.AutoFilterMode = False ' remove filters
End If
End With

insert entire same row beneath when condition was met

I am working on the below code to insert same entire row below/beneath original one. I had a hard time fulfilling the requirement because I am just new to making macros.
I already tried searching but not able to code correctly. It is working to insert an empty row. But what I need is to insert the row that met the condition. Below is the screenshot/code for my macro.
Private Sub CommandButton1_Click()
Dim rFound As Range, c As Range
Dim myVals
Dim i As Long
myVals = Array("LB") '<- starts with 51, VE etc
Application.ScreenUpdating = False
With Range("F1", Range("F" & Rows.Count).End(xlUp))
For i = 0 To UBound(myVals)
.AutoFilter field:=1, Criteria1:=myVals(i)
On Error Resume Next
Set rFound = .Offset(2).Resize(.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
If Not rFound Is Nothing Then
For Each c In rFound
Rows(c.Row + 1).Insert
c.Offset(1, -1).Value = ActiveCell.Value
Next c
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub Test()
Dim rng As Range
Dim rngData As Range
Dim rngArea As Range
Dim rngFiltered As Range
Dim cell As Range
Set rng = Range("A1").CurrentRegion
'Exclude header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=6, Criteria1:="LB"
Set rngFiltered = rngData.Columns("F:F").SpecialCells(xlCellTypeVisible)
rng.AutoFilter Field:=6
For Each rngArea In rngFiltered.Areas
For Each cell In rngArea
'// When inserting a row,
'// iteration variable "cell" is adjusted accordingly.
Rows(cell.Row + 1).Insert
Rows(cell.Row).Copy Rows(cell.Row + 1)
Next
Next
End Sub
Below is the code I just used . Thank you!
Private Sub CommandButton2_Click()
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
End if
Next x
End Sub

copy rows from one sheet to another with multiple criteria

I'm working on a macro that will search a List sheet for different counties and then paste the entire row onto the current sheet. I have a worksheet for each person (named Mark, John, etc.) and each person is assigned several counties. Mark has three counties, listed in cells J1:L1, which I've named as a range (MyCounties). I need a macro that will look through Sheet "List" column "I" for each of those counties and copy the entire row onto Sheet "Mark" starting at "A4". I'm using a modified macro I found on here, but I must be doing something wrong. It is currently giving me an error "Application defined or object defined error" in regards to Set Rng = Sheets("List").Range([I4], Range("I" & Rows.Count).End(xlUp))
Sub NewSheetData()
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim Rng As Range, rCell As Range
Set Rng = Sheets("List").Range([I4], Range("I" & Rows.Count).End(xlUp))
For Each rCell In Range("MyCounties")
On Error Resume Next
With Rng
.AutoFilter , field:=1, Criteria1:=rCell.Value
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
.AutoFilter
End With
On Error GoTo 0
Next rCell
Application.EnableEvents = True
End Sub
This code will need to be adjusted to accommodate your named ranges and worksheet names. It currently uses named ranges with worksheet scope from each worksheet.
Sub NewSheetData()
Dim w As Long, sWSs As Variant, vCrit As Variant, rw As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
sWSs = Array("Mark", "John", "etc")
For w = LBound(sWSs) To UBound(sWSs)
With Worksheets(sWSs(w))
vCrit = .Range("MyCounties").Value2
rw = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 4)
End With
With Worksheets("List")
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(4, "I"), .Cells(.Rows.Count, "I").End(xlUp))
.AutoFilter field:=1, Criteria1:=vCrit, Operator:=xlFilterValues
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If CBool(Application.Subtotal(103, .Cells)) Then
.Cells.EntireRow.Copy Destination:=Worksheets(sWSs(w)).Cells(rw, "A")
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
Next w
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
This uses the values from each worksheet's MyCounties named range as an array of criteria for .AutoFilter. using an array as criteria requires the Operator:=xlFilterValues parameter. It also checks to make sure that there are filtered values to copy before copying them.
may be your EntireRow is copying rows whose first column is blank
you could use UsedRange property of worksheet object to get the last used row
furthermore you'd better place With Rng oustide the loop, since it doesn't change with it
Option Explicit
Sub NewSheetData()
Dim Rng As Range, rCell As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
With Sheets("List")
Set Rng = .Range("I4", .Range("I" & .Rows.Count).End(xlUp))
End With
With Rng
For Each rCell In Range("MyCounties")
.AutoFilter , Field:=1, Criteria1:=rCell.Value
If Application.WorksheetFunction.Subtotal(103, .cells) > 1 Then .Resize(.Rows.Count - 1).Offset(1).EntireRow.Copy _
Sheets("Sheeta2").Range("A" & Sheets("Sheeta2").UsedRange.Rows(Sheets("Sheeta2").UsedRange.Rows.Count).Row).Offset(1)
Next
.Parent.AutoFilterMode = False
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Delete row if the column contains text

I known, this question has been asked thousands of times. But every time I picked up a solution appears error when i debug. (error 1004)
I work with a database with about 300000 lines, where more than half do not care. (I know that have filter, but wanted to erase to reduce the file and speed up the process).
Then if the column M has a keyword like "water", "beer" or "vodka" it will delete the row. I mean, don't need to be the exact word, just the keyword.
OBS: Row 1 it's a table title with the frozen line.
Thanks!
The following code works less than 4 seconds for processing your sample data on my machine:
Sub QuickDeleteRows()
Dim Sheet_Data As Worksheet, NewSheet_Data As Worksheet, Data As Range
Dim Sheet_Name As String, Text As String, Water As Long, Beer As Long, Vodka As Long
On Error GoTo Error_Handler
SpeedUp True
Set Sheet_Data = Sheets("SOVI")
Sheet_Name = Sheet_Data.Name
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim Output(1 To LastRow - 1, 1 To 1) As Long
For i = 1 To LastRow - 1
Text = Cells(i + 1, 13)
Water = InStr(Text, "water")
Beer = InStr(Text, "beer")
Vodka = InStr(Text, "vodka")
If Water > 0 Or Beer > 0 Or Vodka > 0 Then Output(i, 1) = 1
Next
[S2].Resize(LastRow - 1, 1) = Output
LastColumn = Cells(2, Columns.Count).End(xlToLeft).Column
Set Data = Sheet_Data.Range(Cells(1, 1), Cells(LastRow, LastColumn))
Set NewSheet_Data = Sheets.Add(After:=Sheet_Data)
Data.AutoFilter Field:=19, Criteria1:="=1"
Data.Copy
With NewSheet_Data.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteAll
.Cells(1, 1).Select
.Cells(1, 1).Copy
End With
Sheet_Data.Delete
NewSheet_Data.Name = Sheet_Name
NewSheet_Data.Columns(19).Clear
Safe_Exit:
SpeedUp False
Exit Sub
Error_Handler:
Resume Safe_Exit
End Sub
Sub SpeedUp(SpeedUpOn As Boolean)
With Application
If SpeedUpOn Then
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayStatusBar = False
.DisplayAlerts = False
Else
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayStatusBar = True
.DisplayAlerts = True
End If
End With
End Sub
In the future, please post code you've tried first for the community to help you out. That being said, try this out:
Sub Test()
Dim x as Long
Dim i as Long
x = Sheets("SOVI").Range("M" & Rows.Count).End(xlUp).Row
For i = x to 2 Step -1
If InStr(1, Range("M" & i).Value, "water", vbTextCompare) Or InStr(1, Range("M" & i).Value, "beer", vbTextCompare) Or InStr(1, Range("M" & i).Value, "vodka", vbTextCompare) Then
Range("M" & i).entirerow.delete
End If
Next i
End Sub
I would use a slightly different approach, with the Like and with Select Case - this will give you more versatility in the future if you would want to expand it to more types of drinks.
Sub FindDrink()
Dim lRow As Long
Dim i As Long
Dim sht As Worksheet
' always set your sht, modify to your sheet name
Set sht = ThisWorkbook.Sheets("Sheet1")
lRow = sht.Cells(sht.Rows.Count, "M").End(xlUp).Row
For i = lRow To 2 Step -1
Select Case True
Case (sht.Cells(i, "M").Value Like "*beer*") Or (sht.Cells(i, "M").Value Like "*water*") Or (sht.Cells(i, "M").Value Like "*vodka*")
Range("M" & i).EntireRow.Delete
Case Else
' if you decide to do other things in the future for other values
End Select
Next i
End Sub
use excel built in filtering functions for the maximum speed
Autofilter
Option Explicit
Sub main()
Dim keysToErase As Variant, key As Variant
keysToErase = Array("water", "beer", "vodka") '<--| list your keywords to delete matching column "M" rows with
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
For Each key In keysToErase '<--| loop through keys
.AutoFilter field:=13, Criteria1:="*" & key & "*" '<--| filter column "M" with key
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
Next key
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub
AdvancedFilter
Option Explicit
Sub main2()
Application.DisplayAlerts = False '<--| prevent alerts dialog box from appearing at every rows deletion
With Workbooks("test").Worksheets("SOVI").Range("A1").CurrentRegion '<--| this gets the range of all contiguous cells to "A1"
.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=.Parent.Range("U1:U4") '<--| this filters on all keys you placed in cells "U2:U4" with cell "U1" with wanted data header
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete '<--| delete filtered cells, if any
.Parent.ShowAllData '<--| .. show all rows back...
End With
Application.DisplayAlerts = True '<--| allow alerts dialog box back
End Sub
Try with Below code
Sub test()
Application.DisplayAlerts = False
Dim lastrow As Long
Dim i As Long
Dim currentrng As Range
lastrow = Range("M" & Rows.Count).End(xlUp).Row
For i = lastrow To 2 Step -1
Set currentrng = Range("M" & i)
If ((currentrng Like "*water*") Or (currentrng Like "*beer*") Or (currentrng Like "*vodka*")) Then
currentrng.EntireRow.Delete shift:=xlUp
End If
Next i
Application.DisplayAlerts = True
End Sub

Delete method of Range class failed

I have some code where I am using index(match) based on a cell with a dropdown menu. When users select a certain security, a CUSIP is outputted which then pastes formulas from bloomberg to output the data into excel.
I then proceed to create a table but would like to filter the table using autofilter and delete the rows that dont meet the filter criteria but that doesnt seem to be working for some reason! I also have insrted an activex control form button so that when a user double clicks on the dropdown menu they can search for a security and it would autocomplete.
Please help, Thanks!
Sub INDEX_MATCH_CUSIP_TO_SHORTDESCRIPTION()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Sheet4").Range("B3:E100").Delete
Range("B2").Select
test = Application.WorksheetFunction.Index(Sheets("DEX Spread Report (Corp)").Range("B7:B1600"), Application.WorksheetFunction.Match(ActiveCell.Value, Sheets("DEX Spread Report (Corp)").Range("D7:D1600"), 0), 1)
ActiveCell.Offset(1, 0).Value = test
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub BBRG_FORMULAS_FOR_SECURITY()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim CUSIPS As String
Sheets("Sheet4").Select
Range("B2").Select
CUSIPS = ActiveCell.Offset(1, 0).Value
ActiveCell.Offset(2, 0).Value = "=BDS(""" & CUSIPS & """ & ""& CUSIP"",""ALL_HOLDERS_PUBLIC_FILINGS"", ""STARTCOL=1"", ""ENDCOL=1"")"
ActiveCell.Offset(2, 1).Value = "=BDS(""" & CUSIPS & """ & ""& CUSIP"",""ALL_HOLDERS_PUBLIC_FILINGS"", ""STARTCOL=6"", ""ENDCOL=8"")"
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Create_Table_and_AutoFilter()
Dim wksDest As Worksheet
Dim LastRow As Long
Dim rng As Range
Dim rngDelete As Range
Sheets("Sheet4").Select
Set wksDest = Worksheets("Sheet4")
LastRow = Cells(Rows.Count, 2).End(xlUp).row
LastRow1 = Cells(Rows.Count, 2).End(xlUp).row
ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(4, 2), Cells(LastRow, 5)), , xlYes).Name = "HoldersTable"
With wksDest
Set rng = Range(Cells(4, 2), Cells(LastRow1, 5))
rng.AutoFilter Field:=1, Criteria1:="<=1000"
Set rngDelete = rng.SpecialCells(xlCellTypeVisible)
rng.AutoFilter
rngDelete.EntireRow.Delete
End With
End Sub
you're most probably trying to delete table header
try substituting the code from With wksDestto End With with the following snippet:
With wksDest.Range(Cells(4, 2), Cells(LastRow1, 5))
.AutoFilter Field:=1, Criteria1:="<=1000"
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(,1)) > 1 Then .offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With