Related:
- Excel macro delete row if cell contains value
- Excel macro to delete rows based on cell value - Forum - Excel
- Excel - A macro for deleting row on condition - How-To - Excel
- Excel - A macro to delete a particular cell value - How-To - Hardware
- Excel - Macro to highlight Rows with Duplicate values in a cell ✓ - Forum - Excel
- Macros to Delete Rows in Excel 2007 ✓ - Forum - Programming
3 replies
Jason
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
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
JB
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
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
- Posts
-
4476
- Registration date
- Thursday January 28, 2010
- Status
- Contributor
- Last seen
- August 2, 2020
760 > kitkathttps://ccm.net/forum/affich-256874-excel-dependant-copying-summary-sheet
May be with slight changes it will do what you want.
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