Menu
  1. Accueil
  2. Tech Forum
  3. Office Software
  4. Excel
Previous Topic Next Topic

Excel Macro for deleting rows IF cells not... [Solved/Closed]

Report
-
 Jo -
Hello,

I need help to create a Excel macro.
Basicly what I have is a sheet full with information about different departments and what I want to do is delete every row EXCEPT the rows that contain some specified values (wich I would like to enter on running the script).

Lets say in the column that names the department (in my sheet named "Avd"), I would want 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).


Is there any good way to do this?

Thanks very much for your time.

/M
Related:

3 replies

Answer 1 / 3

I spent a lot of time trying to figure this out and finally got the correct Macro. 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 what vaule you want to keep. This is good 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
21
Thank you
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

View all 8 comments
Report
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
 768 > kitkat
Give a look at
https://ccm.net/forum/affich-256874-excel-dependant-copying-summary-sheet

May be with slight changes it will do what you want.
Report
> kitkat
Hi.
I have received an email form somebody but deleted it accidentally so I don't know who was that person and what question had.
Anyway this is what I wrote for my need. Hope it will be useful for you. (Unfortunately I don't have much time to do more for you because I'm very busy man ;) 

Option Explicit
'InterlinearDeletion by Piotr Kuchno 08.01.2010
'This macro lets you delete a row that do not contain a specific string

Dim strToKeep       As String  'string that let us keep a row that contains it
Dim strToCompare    As String  'string taken from a cell(x, y)
Dim rngSrc          As Range   'field size to operate, search and delete
Dim numRows         As Long    'total number of selected rows to operate, search and delete
Dim selCol          As Long    'sel[ected] column
Dim selRow          As Long    'sel[ected] row
Dim compOut         As Integer 'com[pare] out - returns 0 in case of no match or >0 if there is a match
Dim actRow          As Long    'act[ual] row - used temporary in For/Next loop
Dim J               As Long    'for For/Next loop
Dim sheetName       As String  'keeps sheet's name (different languages have it under different name)
Dim DeletedRows     As Long    'just for an information how much rows were deleted

Private Sub cmdStart_Click()
    Call InterlinearOperation
End Sub

Private Sub InterlinearOperation()

    strToKeep = InputBox("Write a (part of) string you want to keep as a whole row:", "Keep Rows")
    If strToKeep = "" Then Exit Sub 'nothing to compare so... exit
    'strToKeep = "your string" 'you may use it instead of InputBox window
    Set rngSrc = ActiveSheet.Range(ActiveWindow.Selection.Address) 'sets the field size

    numRows = rngSrc.Rows.Count 'total number of selected rows
    selCol = rngSrc.Column      'selected column
    selRow = rngSrc.Row         'selected row
    
    sheetName = ActiveSheet.Name 'reads active sheet's name
    
    DeletedRows = 0 'have to start from the scratch
        
    actRow = selRow 'actRow will change so we need to leave 'selRow' intact
    
    For J = selRow To numRows
        strToCompare = Worksheets(sheetName).Cells(actRow, selCol) 'reads a string from cell(x, y)
        compOut = InStr(1, strToCompare, strToKeep, vbTextCompare) 'makes comparison and gives its result
        If strToCompare = "" Then compOut = 1 'cell(x, y) is empty so lets fool it to not deleting
        If compOut = 0 Then                           'not found the string we are looking for so...
            Worksheets(sheetName).Rows(actRow).Select '...selects actual row,...
            Selection.Delete Shift:=xlUp              '...deletes it and shifts all rows up
            actRow = actRow - 1 'we have one row less so we need to mark this for strToCompare
            DeletedRows = DeletedRows + 1 'counts deleted rows
        End If
        actRow = actRow + 1 'comparison is done so we need to increase this array to give the correct number to strToCompare
    Next J
    
    MsgBox "Number of deleted rows: " & DeletedRows

End Sub
Report

HI HOW TO DO THE SAME FOR A COLLECTION STRING INSTEAD OF ONLY ONE STRING
Report

very nice post. tnx
Report

Very useful and something that actually worked! thnx
Answer 2 / 3

Hi,

I have the same challenge, delete every row except for a specified value in col A. I'd like to use the approach listed for the macro, where you highlight a cell's value to keep, and delete everything else. When I pasted in the macro as shown (I don't know a thing about VBA, this is my first time needing to use it), I get the message box, but no value shown that I highlighted before running the macro. I clicked ok, then got a window, "Microsoft Visual Basic, error 400". Can you help this newbe to get the code to run? I've spend days trying to get sample code to work with no results. Thanks, Jim
Answer 3 / 3

Is there a way to have excel delete all the empty columns in a worksheet if the "empty" columns all have a heading in the top cell?
Ask a question

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!