VBA removing table rows with current macro

[MasterBash]

Hello,

I am doing an all-in-one macro to rearrange a table.



AIR
UPS
Shipped


AIR
FEDEX
In-progress


GROUND

In-progress


OCEAN
FEDEX
...


OCEAN
UPS
...



I would like to delete all rows containing OCEAN and UPS, while leaving the other ones alone. Currently, those would be D and F in my table.

Currently, my vba script looks like this to remove duplicates and sort the table out. I would also like to remove rows along with this.



Sub RemDupSort()
Dim r As Range, r1 As Range

Application.ScreenUpdating = False

Set r = ActiveSheet.Cells(1, 1).CurrentRegion
Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)

r.RemoveDuplicates Columns:=2, Header:=xlYes

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(6), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With


End Sub


How can I accomplish this, adding to the macro above and without using a specific table name ?
Also, data is available on the right side of the table when it is not sorted. It does not contain data when it is sorted.

Thank you.

[Aussiebear]

Maybe something like this



Sub DeleteRow()
Dim lastRow As Long
With ActiveSheet
lastRow = .Range("D" & Rows.Count).End(xlUp).Row
For r = lastRow To 2 Step -1
If .Range("D:E" & r).Value = "Ocean" And “UPS” Then
.Rows(r).Delete
Else
End If
Next r
End With
End Sub

[Dave]

If .Range("D" & r & ":F" & r).Value = "Ocean" And _
.Range("D" & r & ":F" & r).Value = “UPS” Then

:) Dave

[Aussiebear]

Thank you Dave. I had a feeling it wasn't as simple as I initially thought.

[MasterBash]

Thank you ! Unfortunately, I do get an error.

If I added this to my current script :


Sub RemDupSort()
Dim r As Range, r1 As Range
Dim lastRow As Long

Application.ScreenUpdating = False

Set r = ActiveSheet.Cells(1, 1).CurrentRegion
Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)

r.RemoveDuplicates Columns:=2, Header:=xlYes

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(6), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With ActiveSheet
lastRow = .Range("D" & Rows.Count).End(xlUp).Row
For r = lastRow To 2 Step -1
If .Range("D" & r & ":F" & r).Value = "Ocean" And _
.Range("D" & r & ":F" & r).Value = “UPS” Then
.Rows(r).Delete
Else
End If
Next r
End With


End Sub



Is that correct ? In this case, I do get Compile error type mismatch. It points to the r (For r = lastRow To 2 Step -1).

[Dave]

You dimmed "r" as a range.... it needs to be an integer for the loop. I was following Aussiebear's lead but my bad anyways. Rename/replace the "r" in the loop to some other named integer. HTH. Dave

[MasterBash]

Thank you but unfortunately, I still get an error. I must be doing something wrong. This time it is Run-time error '13' : Type mismatch.



Sub RemDupSort()
Dim r As Range, r1 As Range
Dim lastRow As Long
Dim r2 As Integer

Application.ScreenUpdating = False

Set r = ActiveSheet.Cells(1, 1).CurrentRegion
Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)

r.RemoveDuplicates Columns:=2, Header:=xlYes

With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(6), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With ActiveSheet
lastRow = .Range("D" & Rows.Count).End(xlUp).Row
For r2 = lastRow To 2 Step -1
If .Range("D" & r2 & ":F" & r2).Value = "Ocean" And _
.Range("D" & r2 & ":F" & r2).Value = "UPS" Then
.Rows(r2).Delete
Else
End If
Next r2
End With


End Sub


Now it is both of these :
If .Range("D" & r2 & ":F" & r2).Value = "Ocean" And _
.Range("D" & r2 & ":F" & r2).Value = "UPS" Then

[Dave]

After a re-read, you only want to delete the row when "D" is "Ocean" and "F" is "UPS". The previous was all wrong and was impossible. The range D:F for a row would have had to both equal "Ocean" and "UPS" :bug:
The type mismatch was probably using value for an extended range. It should simply be..

If .Range("D" & r2).Value = "Ocean" And .Range("F" & r2).Value = "UPS" Then
Dave

[Paul_Hossler]

It's easier if you attach a sample workbook, so these are just some guesses



Option Explicit


Sub RemDupSort()
Dim r As Range, r1 As Range

Application.ScreenUpdating = False

With ActiveSheet

.Cells(1, 1).CurrentRegion.RemoveDuplicates Columns:=2, Header:=xlYes

For Each r In .Cells(1, 1).CurrentRegion.Rows
If r.Cells(4).Value = "OCEAN" And r.Cells(5).Value = "UPS" Then r.Cells(4).Value = True
Next

On Error Resume Next
.Columns(4).SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
On Error GoTo 0

Set r = .Cells(1, 1).CurrentRegion
Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)

With .Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(6), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With

Application.ScreenUpdating = True


End Sub

[Paul_Hossler]

Here's another way that uses filters



Option Explicit


Sub Macro4()

Dim rData As Range, rFilteredData As Range, rSortData As Range

Application.ScreenUpdating = False


With ActiveSheet
If Not .AutoFilterMode Then .Rows("1:1").AutoFilter

Set rData = .Cells(1, 1).CurrentRegion
rData.AutoFilter Field:=4, Criteria1:="OCEAN"
rData.AutoFilter Field:=5, Criteria1:="UPS"

On Error Resume Next
Set rFilteredData = rData.SpecialCells(xlCellTypeVisible)
Set rFilteredData = Intersect(rFilteredData, rData.Offset(1, 0))

rFilteredData.EntireRow.Delete
On Error GoTo 0

.ShowAllData
.Rows(1).AutoFilter

Set rData = .Cells(1, 1).CurrentRegion
Set rSortData = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)

With .Sort
.SortFields.Clear
.SortFields.Add Key:=rSortData.Columns(6), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

End With


Application.ScreenUpdating = True
End Sub

[MasterBash]

For some reasons, none of those are working. It deletes everything minus the first line after the header.

I am probably doing something wrong. I attached the file as an example. All colums have data in them.

31706

[Paul_Hossler]

All the cells in column 2 = blank, so they're all dups and were deleted by this line ...


.Cells(1, 1).CurrentRegion.RemoveDuplicates Columns:=2, Header:=xlYes

You had the line in the code in post#1 so I just left it

Remove it or have real data in column 2

[MasterBash]

Huh, my bad.

This isn't actually the problem.

Column D changes to True but rows are not getting deleted. I re-uploaded the workbook.

Before running the script
31709

This is after running the script.
31708

[Aussiebear]

Naming of files..... Can you at least rename your files to enable others to follow your logic. testdup1 and testdup2 for example.

[Paul_Hossler]

Using a ListObject table (instead of the Range-type table) is a little different

Someone who is more knowledgable about ListObjects could probably clean this up, but it seems to work




Option Explicit




Sub RemDupSort()
Dim r As Range, r1 As Range
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

.Cells(1, 1).CurrentRegion.RemoveDuplicates Columns:=2, Header:=xlYes

With .ListObjects(1)
For i = .DataBodyRange.Rows.Count To 1 Step -1
If .ListColumns("Column4").DataBodyRange.Cells(i) = "UPS" And _
.ListColumns("Column6").DataBodyRange.Cells(i) = "Ocean" Then
.ListRows(i).Delete
End If
Next
End With

Set r = .Cells(1, 1).CurrentRegion
Set r1 = r.Cells(2, 1).Resize(r.Rows.Count - 1, r.Columns.Count)

With .Sort
.SortFields.Clear
.SortFields.Add Key:=r1.Columns(6), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange r
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With

Application.ScreenUpdating = True




End Sub

[MasterBash]

Oh wow, this works. Thank you, Paul. :)