Need to genericize VBA code

LAAdams17

Board Regular
Joined
Oct 23, 2009
Messages
73
I need help making the code in Macro2 (see below) work on the active table which can start on A1 or another row. What I'm attempting to do is run the DeleteHiddenRows9 macro, move to the first column, sort the table based on data in the first column (smallest to largest), find the last cell with data, delete all rows in the table that don't have data, then go back to the header row in the first column. My company is still on Excel 2013 :( . Thank you!



-------------------------------------

Sub DeleteHiddenRows9()

Dim r As Range, q As Range



Set q = ActiveSheet.UsedRange.Columns("A").Offset(1)

Set r = q.SpecialCells(xlCellTypeVisible)



Range(ActiveCell.Address).AutoFilter

r.EntireRow.Hidden = True

q.SpecialCells(xlCellTypeVisible).EntireRow.ClearContents

q.EntireRow.Hidden = False



End Sub



--------------------------------



Sub Macro2()


Selection.End(xlToLeft).Select

Selection.AutoFilter

ActiveWorkbook.Worksheets("Open - DupeReview").ListObjects("Table_DupeReview"). _

Sort.SortFields.Clear

ActiveWorkbook.Worksheets("Open - DupeReview").ListObjects("Table_DupeReview"). _

Sort.SortFields.Add Key:=ActiveCell.Offset(-1, 0).Range("A1:A2782"), SortOn _

:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets("Open - DupeReview").ListObjects( _

"Table_DupeReview").Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Selection.End(xlDown).Select

ActiveCell.Offset(1, 0).Rows("1:1").EntireRow.Select

Range(Selection, Selection.End(xlDown)).Select

Selection.Delete Shift:=xlUp

ActiveCell.Offset(-1, 0).Range("A1").Select

Selection.End(xlUp).Select

End Sub
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Try this:
Put the cursor inside the table then run this code:
VBA Code:
Sub a1167601b()
Dim r As Range, q As Range, a As Range, b As Range
Dim tbl As ListObject

If Not Selection.ListObject Is Nothing Then
    Set tbl = Selection.ListObject
Else
    MsgBox "Please put the cursor in the table"
End If

Set q = tbl.DataBodyRange.Columns(1)
Set r = q.SpecialCells(xlCellTypeVisible)

tbl.AutoFilter.ShowAllData

r.EntireRow.Hidden = True
q.SpecialCells(xlCellTypeVisible).Rows.ClearContents
q.EntireRow.Hidden = False

tbl.Range.Sort Key1:=tbl.Range.Cells(1), Order1:=xlAscending, Header:=xlYes

'first blank row
Set a = tbl.Range.Cells(1).End(xlDown).Offset(1)
'last row
Set b = a.End(xlDown)

If Not Intersect(b, tbl.DataBodyRange) Is Nothing Then
    Range(a, b).Rows.Delete xlUp
Else 'if there's only 1 blank row
    a.Rows.Delete xlUp
End If

End Sub

The code will:
1. clear content of the hidden row of the first column
2. sort data by first column
3. delete rows where first column is blank.

the table could start at any column and any row.
 
Upvote 0
Solution
Try this:
Put the cursor inside the table then run this code:
VBA Code:
Sub a1167601b()
Dim r As Range, q As Range, a As Range, b As Range
Dim tbl As ListObject

If Not Selection.ListObject Is Nothing Then
    Set tbl = Selection.ListObject
Else
    MsgBox "Please put the cursor in the table"
End If

Set q = tbl.DataBodyRange.Columns(1)
Set r = q.SpecialCells(xlCellTypeVisible)

tbl.AutoFilter.ShowAllData

r.EntireRow.Hidden = True
q.SpecialCells(xlCellTypeVisible).Rows.ClearContents
q.EntireRow.Hidden = False

tbl.Range.Sort Key1:=tbl.Range.Cells(1), Order1:=xlAscending, Header:=xlYes

'first blank row
Set a = tbl.Range.Cells(1).End(xlDown).Offset(1)
'last row
Set b = a.End(xlDown)

If Not Intersect(b, tbl.DataBodyRange) Is Nothing Then
    Range(a, b).Rows.Delete xlUp
Else 'if there's only 1 blank row
    a.Rows.Delete xlUp
End If

End Sub

The code will:
1. clear content of the hidden row of the first column
2. sort data by first column
3. delete rows where first column is blank.

the table could start at any column and any row.
Seriously, you should sell this! I've been looking for a quick solution for deleting hidden rows in large spreadsheets for a long time and this solution is by the best I've seen. I do suggest you add a couple of lines of additional code. This makes it run even faster and resets the cursor so one sees the results instead of a blank area where rows were deleted. THANK YOU AGAIN. This is great!

Toward the beginning:

Application.ScreenUpdating = False


At the end:

Application.ScreenUpdating = True

Application.Goto Reference:="R1C1"

ActiveWindow.ScrollColumn = 1

ActiveWindow.ScrollRow - 1
 
Upvote 0
You're welcome, glad to help & thanks for the feedback. :)

Using Application.ScreenUpdating = False is a good idea.(y)

Note:
However there is an issue with "SpecialCells" in that Excel only supports a maximum of 8,192 non-contiguous cells via VBA macros.
The SpecialCells(xlCellTypeBlanks) VBA function doesn't work as expected - Office

but actually I made a test with 10K non-contiguous cells, the macro still works correctly. I'm using Excel 365.
Could you do a test with 10K non-contiguous cells or more on Excel 2013?
 
Upvote 0
Try this:
Put the cursor inside the table then run this code:
VBA Code:
Sub a1167601b()
Dim r As Range, q As Range, a As Range, b As Range
Dim tbl As ListObject

If Not Selection.ListObject Is Nothing Then
    Set tbl = Selection.ListObject
Else
    MsgBox "Please put the cursor in the table"
End If

Set q = tbl.DataBodyRange.Columns(1)
Set r = q.SpecialCells(xlCellTypeVisible)

tbl.AutoFilter.ShowAllData

r.EntireRow.Hidden = True
q.SpecialCells(xlCellTypeVisible).Rows.ClearContents
q.EntireRow.Hidden = False

tbl.Range.Sort Key1:=tbl.Range.Cells(1), Order1:=xlAscending, Header:=xlYes

'first blank row
Set a = tbl.Range.Cells(1).End(xlDown).Offset(1)
'last row
Set b = a.End(xlDown)

If Not Intersect(b, tbl.DataBodyRange) Is Nothing Then
    Range(a, b).Rows.Delete xlUp
Else 'if there's only 1 blank row
    a.Rows.Delete xlUp
End If

End Sub

The code will:
1. clear content of the hidden row of the first column
2. sort data by first column
3. delete rows where first column is blank.

the table could start at any column and any row.

You're welcome, glad to help & thanks for the feedback. :)

Using Application.ScreenUpdating = False is a good idea.(y)

Note:
However there is an issue with "SpecialCells" in that Excel only supports a maximum of 8,192 non-contiguous cells via VBA macros.
The SpecialCells(xlCellTypeBlanks) VBA function doesn't work as expected - Office

but actually I made a test with 10K non-contiguous cells, the macro still works correctly. I'm using Excel 365.
Could you do a test with 10K non-contiguous cells or more on Excel 2013?
Can you either provide the spreadsheet or tell me how you'd like it set up?
 
Upvote 0
This is how I did the test:
Run this sub:
it will create 20K rows of data (X & Y)
VBA Code:
Sub insert_data1()
Dim i As Long, j As Long, n As Long
Dim va

n = 20000
ReDim va(1 To n, 1 To 1)
For i = 1 To n Step 2
    va(i, 1) = "X"
    va(i + 1, 1) = "Y"
Next
Range("A1").Resize(n, 1) = va


End Sub

then run this sub:
- it will filter data by "Y" & it will make 10K non-contiguous range (see Debug.Print "Areas count : ")
- it changes visible cell content to Z
VBA Code:
Sub try_1()
Dim r As Range
Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp))

'filter with "Y"
r.AutoFilter Field:=1, Criteria1:="Y"
'count non-contiguous areas
Debug.Print "Areas count : " & r.Offset(1).SpecialCells(xlCellTypeVisible).Areas.Count

'change visible cells content to "Z"
r.SpecialCells(xlCellTypeVisible).Value = "Z"

r.AutoFilter

End Sub

and it worked correctly, all Y changed to Z, so there's no issue with 10K non-contiguous range of data.
 
Upvote 0
This is how I did the test:
Run this sub:
it will create 20K rows of data (X & Y)
VBA Code:
Sub insert_data1()
Dim i As Long, j As Long, n As Long
Dim va

n = 20000
ReDim va(1 To n, 1 To 1)
For i = 1 To n Step 2
    va(i, 1) = "X"
    va(i + 1, 1) = "Y"
Next
Range("A1").Resize(n, 1) = va


End Sub

then run this sub:
- it will filter data by "Y" & it will make 10K non-contiguous range (see Debug.Print "Areas count : ")
- it changes visible cell content to Z
VBA Code:
Sub try_1()
Dim r As Range
Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp))

'filter with "Y"
r.AutoFilter Field:=1, Criteria1:="Y"
'count non-contiguous areas
Debug.Print "Areas count : " & r.Offset(1).SpecialCells(xlCellTypeVisible).Areas.Count

'change visible cells content to "Z"
r.SpecialCells(xlCellTypeVisible).Value = "Z"

r.AutoFilter

End Sub

and it worked correctly, all Y changed to Z, so there's no issue with 10K non-contiguous range of data.
It also worked properly on Excel 2013.
 
Upvote 0
OK.
Just to be safe, I added some lines to check if number of visible row before & after deleting hidden rows are different. Both should be the same, so if they are different then a message "Something's wrong. " will pop up.

VBA Code:
Sub a1167601c()

Dim r As Range, q As Range, a As Range, b As Range
Dim tbl As ListObject
Dim p As Long

If Not Selection.ListObject Is Nothing Then
    Set tbl = Selection.ListObject
Else
    MsgBox "Please put the cursor in the table"
    Exit Sub
End If

Set q = tbl.DataBodyRange.Columns(1)
Set r = q.SpecialCells(xlCellTypeVisible)

p = r.Cells.Count

tbl.AutoFilter.ShowAllData

r.EntireRow.Hidden = True
q.SpecialCells(xlCellTypeVisible).Rows.ClearContents
q.EntireRow.Hidden = False

tbl.Range.Sort Key1:=tbl.Range.Cells(1), Order1:=xlAscending, Header:=xlYes

'first blank row
Set a = tbl.Range.Cells(1).End(xlDown).Offset(1)
'last row
Set b = a.End(xlDown)

If Not Intersect(b, tbl.DataBodyRange) Is Nothing Then
    Range(a, b).Rows.Delete xlUp
Else 'if there's only 1 blank row
    a.Rows.Delete xlUp
End If


If q.Cells.Count = p Then
    MsgBox "It's done"
Else 'if number of visible row before & after deleting are different
    MsgBox "Something's wrong. " & vbLf & _
   "number of visible row before deleting  : " & p & vbLf & _
   "number of row after deleting  : " & q.Cells.Count
End If

End Sub
 
Upvote 0
OK.
Just to be safe, I added some lines to check if number of visible row before & after deleting hidden rows are different. Both should be the same, so if they are different then a message "Something's wrong. " will pop up.

VBA Code:
Sub a1167601c()

Dim r As Range, q As Range, a As Range, b As Range
Dim tbl As ListObject
Dim p As Long

If Not Selection.ListObject Is Nothing Then
    Set tbl = Selection.ListObject
Else
    MsgBox "Please put the cursor in the table"
    Exit Sub
End If

Set q = tbl.DataBodyRange.Columns(1)
Set r = q.SpecialCells(xlCellTypeVisible)

p = r.Cells.Count

tbl.AutoFilter.ShowAllData

r.EntireRow.Hidden = True
q.SpecialCells(xlCellTypeVisible).Rows.ClearContents
q.EntireRow.Hidden = False

tbl.Range.Sort Key1:=tbl.Range.Cells(1), Order1:=xlAscending, Header:=xlYes

'first blank row
Set a = tbl.Range.Cells(1).End(xlDown).Offset(1)
'last row
Set b = a.End(xlDown)

If Not Intersect(b, tbl.DataBodyRange) Is Nothing Then
    Range(a, b).Rows.Delete xlUp
Else 'if there's only 1 blank row
    a.Rows.Delete xlUp
End If


If q.Cells.Count = p Then
    MsgBox "It's done"
Else 'if number of visible row before & after deleting are different
    MsgBox "Something's wrong. " & vbLf & _
   "number of visible row before deleting  : " & p & vbLf & _
   "number of row after deleting  : " & q.Cells.Count
End If

End Sub
Cool. Thank you!
 
Upvote 0

Forum statistics

Threads
1,213,551
Messages
6,114,267
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top