Microsoft Excel is one of the handiest tools to play around with numbers. In instances where a huge number of rows or columns are involved, Excel also has the
visual basic framework that can be used to record or write
custom macros.
VBA macros allow users to automate the process by having a minimum user input. These
macros can be customized to work on specific values or rows. The user can also customize what should be the start and end ranges for specific values or rows. All these options increase Excel's use as a
data handling application.
Issue
Basically what I have is a sheet full of information about different departments and what I want to do is delete every row EXCEPT the rows that contain some specified values (which I would like to enter on running the script).
Let's say in the column that names the department (in my sheet named "Avd"), I would like the script to look for any cell that does not contain, for example, the numbers 1, 3, 5, 6 or 21... and so on (I have about 36 different numbers).
Solution
All you have to do is highlight the information in the column and then run the following Macro. There will be a box that will prompt you to select what value you want to keep. This is available for up to 30,000 rows.
Sub DeleteRows()
Dim strToDelete As String
Dim rngSrc As Range
Dim NumRows As Integer
Dim ThisRow As Integer
Dim ThatRow As Integer
Dim ThisCol As Integer
Dim J As Integer
Dim DeletedRows As Integer
strToDelete = InputBox("Value to Trigger Keep, Jason????", "Delete Rows")
Set rngSrc = ActiveSheet.Range(ActiveWindow.Selection.Address)
NumRows = rngSrc.Rows.Count
ThisRow = rngSrc.Row
ThatRow = ThisRow + NumRows - 1
ThisCol = rngSrc.Column
Dim topRows As Integer
Dim bottomRows As Integer
bottomRows = 30000
For J = ThisRow To NumRows Step 1
If Cells(J, ThisCol) = strToDelete Then
'Rows(J).Select
topRows = J
Exit For
DeletedRows = DeletedRows + 1
End If
Next J
For J = (topRows + 1) To NumRows Step 1
If Cells(J, ThisCol) <> strToDelete Then
'Rows(J).Select
bottomRows = J
Exit For
'DeletedRows = DeletedRows + 1
End If
Next J
If topRows <> 4 Then
ActiveSheet.Range(Cells(4, 1), Cells(topRows - 1, 52)). Select
Selection.delete Shift:=xlUp
End If
ActiveSheet.Range(Cells(bottomRows - topRows + 4, 1), Cells(30000, 52)). Select
Selection.delete Shift:=xlUp
'MsgBox "Number of deleted rows: " & DeletedRows
End Sub
Note that
Thanks to
Jason for this tip on the forum.
See also
Knowledge communities.
Published by
aakai1056 -
Latest update by Jeff
