I run my VBA code and the first time it runs I get the result I want but if I run it a second time my column headers get deleted. FYI my table starts on E and goes through N. My button is on column O and also gets deleted when I run it a second time.
Switching the Range did not help and setting AutoFilter to false also did not work.
#
Sub Auto_filter()
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("HP Service Manager")
sh.AutoFilterMode = False
With sh
On Error Resume Next
.ShowAllData
.Range("E1:N1").AutoFilter 1, "IM*"
AutoFilter = False
End With
End Sub
#
Expect to not have column headers deleted.
The issue is in the second code you shared.
The code is first setting the range here:
Set Rng = Range("E1", Cells(iRow, "E"))
And then here it is trying to delete all visible cells in the range (after applying the filter)
Rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
which also includes your header cell.
So, a simple way to deal with it could be to set another range like this
Set Rng2 = Range("E2", Cells(iRow, "E"))
and then using it to delete the data
Rng2.SpecialCells(xlCellTypeVisible).EntireRow.Delete
Here is the re-written function for your reference. This only deletes the rows starting from row 2 that are blank. You may want to add some error handing in case there are no blank rows to delete etc.
Sub DeleteRowsAll()
Dim iRow As Long
Dim Rng As Range
Application.ScreenUpdating = False
Rows(1).Insert
Range("E1").Value = "rabbitohs"
With ActiveSheet
.UsedRange
iRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
Set Rng = Range("E1", Cells(iRow, "E"))
Rng.AutoFilter Field:=1, Criteria1:=""
Set Rng2 = Range("E2", Cells(iRow, "E"))
Rng2.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.UsedRange
End With
End Sub
Sub DeleteRowsAll()
Dim LastRow As Long
Dim CellValue As String
LastRow = Worksheets("HP Service Manager").Cells(Rows.Count, "E").End(xlUp).Row
For i = LastRow To 2 Step -1
CellValue = Worksheets("HP Service Manager").Cells(i, "E").Value
If CellValue = "" Then
Worksheets("HP Service Manager").Rows(i).Delete
End If
Next i
End Sub
Related
I am trying to wrap my head around a piece of code that has worked for me in the past not working right now in a different application. Basically it needs to delete all rows that contain information in a specific column and leave the rest untouched. When I run the macro the code executes without issues, but just deletes some of the rows with values, not all of them. When running the code several times in a row it ends up doing what it is intended, but it's really not convenient. Here is the code:
Sub Delete_Signoffed()
Dim rCell As Range
Dim iCol As Integer
Dim iRow As Integer
Worksheets("MilestoneDueDate").Activate
If ActiveSheet.AutoFilterMode Then Cells.AutoFilter
ActiveWindow.FreezePanes = False
Columns.EntireColumn.Hidden = False
If WorksheetFunction.CountA(Columns("A")) = 0 Then
Columns("A").Delete
Rows("1:6").Delete
End If
iCol = Cells.Find("Sign-Off By", LookAt:=xlWhole).Column
For iRow = 2 To Cells(Rows.Count, iCol).End(xlUp).Row
Cells(iRow, iCol).Select
If Not IsEmpty(Cells(iRow, iCol).Value) Then Rows(iRow).EntireRow.Delete
Next iRow
End Sub
The source file has some formatting issues, everything that comes before assigning iCol the column value is to fix the format, so please ignore. iRow starts at 2 to avoid deleting the file headers.
Any ideas on why the For loop is not working as intended?
Thanks in advance!
I updated your script. I also added comments for you to be able to understand it better and able to improve it in the future.
Sub Delete_Signoffed()
'Goto CleanUp if there are errors
On Error GoTo CleanUp
Dim wsMilestoneDueDate As Worksheet
Dim rCell As Range
Dim iCol As Integer
Dim iRow As Integer
Set wsMilestoneDueDate = ActiveWorkbook.Worksheets("MilestoneDueDate")
'Disable temporarily Screen Updating
Application.ScreenUpdating = False
With wsMilestoneDueDate
.Activate 'No need, but if you prefer you can
'Activate Auto Filter
If .AutoFilterMode Then Cells.AutoFilter
'Remove FreezePanes
ActiveWindow.FreezePanes = False
'Unhide Columns
.Columns.EntireColumn.Hidden = False
'Delete Empty Columns/Rows if they are all empty
If WorksheetFunction.CountA(.Columns("A")) = 0 Then
Columns("A").Delete
Rows("1:6").Delete
End If
'Get the last Column
iCol = .UsedRange.Find("Sign-Off By", LookAt:=xlWhole).Column
'Start Deleting but from the last to the first (Backward)
For iRow = Cells(Rows.Count, iCol).End(xlUp).Row To 2 Step -1
Set rCell = Cells(iRow, iCol)
'Delete the entire row if it is NOT empty
If Not IsEmpty(rCell.Value) Then
'Deletion
Rows(iRow).EntireRow.Delete
End If
Next iRow
End With
CleanUp:
'Purge Memory
Set wsMilestoneDueDate = Nothing
Set rCell = Nothing
'Restore Screen Updating
Application.ScreenUpdating = True
End Sub
As already stated in comments, the flaw in your code was not looping backwards
But I hereby give you a solution without looping and using one line only, thanks to SpecialCells method of Range object, specifying it to filter cells with some "constant" (i.e. not deriving from formulas) value
Range(Cells(2, iCol), Cells(Rows.Count, iCol).End(xlUp)).SpecialCells(xlCellTypeConstants).EntireRow.Delete
this assumes you always have at least one value below row 1
should not that be the case then just add a check:
If Cells(Rows.Count, iCol).End(xlUp).Row > 1 Then Range(Cells(2, iCol), Cells(Rows.Count, iCol).End(xlUp)).SpecialCells(xlCellTypeConstants).EntireRow.Delete
While looking at your entire code you should adopt the good practice to avoid Select/Selection, Activate/ActiveXXX pattern and Always fully qualify ranges up to their worksheet (if not workbook) parent objects, like follows:
Sub Delete_Signoffed()
Dim iCol As Long
With Worksheets("MilestoneDueDate") ' reference wanted sheet
If .AutoFilterMode Then .Cells.AutoFilter
ActiveWindow.FreezePanes = False
.Columns.EntireColumn.Hidden = False
If WorksheetFunction.CountA(.Columns("A")) = 0 Then
.Columns("A").Delete
.Rows("1:6").Delete
End If
iCol = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).Find("Sign-Off By", LookAt:=xlWhole, LookIn:=xlValues).Column
.Range(.Cells(2, iCol), .Cells(.Rows.Count, iCol).End(xlUp)).SpecialCells(xlCellTypeConstants).EntireRow.Delete
End With
End Sub
as you can see
all range objects (Columns(), Rows, Range, Cells) are referencing Worksheets("MilestoneDueDate") through that dot (.) in front of them
iCol is being set running Find() method in the most restricted range possibile
UPDATE:
Data set is made of strings that are number though (I don't get it) -> I can do all the math stuff with them as with regular numbers.
Problem is I need to separate cells that look like this "186.85" and cells that look like this "1.76 Dividend".
====================
I need a loop to check row by row if the cell contains some text (word "dividend" specifically) or if it's just number. If it is a text, then delete it and move to the next row.
It does some deleting BUT it wipes like 50 rows of data almost every time (I have only two text populated rows in this particular data set). These rows are numbers.
Dim i As Long
i = 2
Do
If WorksheetFunction.IsText(Sheets("Data").Cells(i, 5)) = True Then
If Not Worksheets("Data").Cells(i, 5).Value = "" Then
Worksheets("Data").Rows(i).Delete
End If
End If
i = i + 1
Loop Until i = 100
I expected to loop through the data and delete the entire row if a cell contains text.
This code so far deletes things kinda randomly.
The below has been updated to a dynamic range. This will not need modification regardless of how many rows your sheet has.
More importantly, deleting rows inside a loop will cause your range to shift at every deletion. The way around this is to loop backwards
OR, even better..
Don't delete cells inside your loop. Every time your criteria is met, you force an action (deletion). Instead, gather up all of the cells to be deleted inside your loop and then delete the entire collection (Union) all at once outside of the loop. This requires 1 action in total rather 1 action per text instance
Sub Looper()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update sheet name
Dim i As Long, LR As Long
Dim DeleteMe As Range
LR = ws.Range("E" & ws.Rows.Count).End(xlUp).Row
For i = 2 To LR
If WorksheetFunction.IsText((ws.Range("E" & i))) Then
If Not DeleteMe Is Nothing Then
Set DeleteMe = Union(DeleteMe, ws.Range("E" & i))
Else
Set DeleteMe = ws.Range("E" & i)
End If
End If
Next i
If Not DeleteMe Is Nothing Then DeleteMe.EntireRow.Delete
End Sub
Try something like this:
Sub test()
Dim i As Long
For i = 100 To 2 Step -1
With ThisWorkbook.Worksheets("Data")
If WorksheetFunction.IsText(.Cells(i, 5)) = True Then
If Not .Cells(i, 5).Value = "" Then
.Rows(i).EntireRow.Delete
End If
End If
End With
Next i
End Sub
You can use SpecialCells with xlCellTypeConstants-2... No need for a loop. See Range.SpecialCells method (Excel) and XlSpecialCellsValue enumeration (Excel)
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rng As Range
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
On Error Resume Next
Set rng = .Columns(5).SpecialCells(xlCellTypeConstants, 2)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
End Sub
Thank you all for quick responses and effort.
I managed to get this solution working with InStr() function:
''loop through the Data and remove all rows containing text (Dividend payments which we don't need)
Dim i As Long
Dim ws As Worksheet
Dim searchText As String
Dim searchString As String
i = 2
Set ws = Sheets("Data")
Do Until ws.Cells(i, 2).Value = ""
searchText = "Dividend"
searchString = ws.Cells(i, 2).Value
If InStr(searchString, searchText) Then
ws.Rows(i).Delete
End If
i = i + 1
Loop
As the photo shows, all my data is on ONE column. The "trigger word" is "Past Car" and want that entire row PLUS the two rows under it deleted.
So according to the photo below rows 5,6,7 and 18,19,20 and 26,27,28 would be deleted.
Is this possible with VBA? I've tried using search functions and some VBA techniques but got overwhelmed.
Screenshot
I would suggest to do it like that
Option Explicit
Sub DelIt()
Const PAST_CAR = "Past Car"
Const OFF_SET = 3
Dim lastRow As Long, i As Long
Dim ws As Worksheet
Dim deleteRange As Range
Set ws = ActiveSheet
lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
With ws
For i = 1 To lastRow
If .Cells(i, 1).Value = PAST_CAR Then
If deleteRange Is Nothing Then
Set deleteRange = .Rows(i).Resize(OFF_SET)
Else
Set deleteRange = Union(deleteRange, .Rows(i).Resize(OFF_SET))
End If
End If
Next i
End With
If Not (deleteRange Is Nothing) Then
deleteRange.EntireRow.Delete
End If
End Sub
In this way you do not need to loop backwards or turn of ScreenUpdatings as you only have one "write" access to the sheet.
You must loop through the cells in column A in reverse order and check if the cell content is Past Car and if so, delete the rows accordingly.
You may try something like this...
Sub DeleteRows()
Dim lr As Long, i As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = lr To 1 Step -1
If Cells(i, 1) = "Past Car" Then
Range("A" & i).Resize(3).EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
I am trying to write a macro that hides the row if the cell value equals the next visible cell in that column and loops through the whole column. I have read that SpecialCells(xlCellTypeVisible) only works up to 8192 cells and my spreadsheet has 15,000 rows.
I have tried something like this but want to restrict it to only visible cells
Sub Test()
For i = 7 To 15258
If Range("P" & i).Value = Range("P" & i + 1).Value Then
Rows(i).Hidden = True
End If
Next i
End Sub
I have tried to search for a solution but haven't been able to find one yet.
Thanks!
I'd be surprised if this couldn't be optimized just a little bit, but it will work for what you are needing.
You can follow the comments within the code itself to kind of get a sense of what it's doing, but in a nutshell, you are using a For...Next statement to loop through your visible cells. For each visible cell, you will search for the next visible cell and then check to see if that matches. If it does, you add that cell to a special range that tracks all the rows to hide at the end of the code, then hide it.
Sub Test()
Dim ws As Worksheet, lookupRng As Range, rng As Range, lstRow As Long
Set ws = ThisWorkbook.Worksheets(1)
lstRow = 15258
Set lookupRng = ws.Range("P7:P" & lstRow)
Dim rngToHide As Range, i As Long
For Each rng In lookupRng.SpecialCells(xlCellTypeVisible)
Application.StatusBar = "Checking row " & rng.Row & " for matches."
For i = rng.Row + 1 To lstRow 'Loop through rows after rng
If Not ws.Rows(i).Hidden Then 'Check if row is hidden
If rng.Value = ws.Cells(i, "P") Then 'check if the non-hidden row matches
If rngToHide Is Nothing Then 'Add to special range to hide cells
Set rngToHide = ws.Cells(i, "P")
Else
Set rngToHide = Union(rngToHide, ws.Cells(i, "P"))
End If
End If
Exit For 'Exit the second For statement
End If
Next i
Next rng
Application.StatusBar = "Hiding duplicate rows"
If Not rngToHide Is Nothing Then rngToHide.EntireRow.Hidden = True
Application.StatusBar = False
End Sub
I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps