I have the following code which should simply select a range of rows and delete them. Unfortunately it deletes the headers as well, no matter how I change the range.
I tried to change the "rng" parameter without success.
Thank you for the feedback you can provide.
Sub delete_rows_range()
'Application.ScreenUpdating = False
Dim rng, Rng_del As Range
Dim leg As Range
Set leg = Worksheets("Sheet1").Range("aB1")
Set rng = Worksheets("Sheet1").Range("b1")
If Worksheets("Sheet1").AutoFilterMode = True Then
Worksheets("Sheet1").AutoFilter.ShowAllData
End If
rng.Select
rng.AutoFilter Field:=2, Criteria1:=leg
'rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.delete
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select
Worksheets("Sheet1").AutoFilterMode = False
End Sub
Your problem is that you are using a single cell as the range.
When you .Offset a single cell range, then use `xlCelTypeVisible.EntireRow.Delete
Excel selects every cell on the sheet and deletes them.
You really should clarify your range with a properly defined range object. e.g.
Dim ws As Worksheet, lRow As Long, rng As Range
Set ws = Worksheets("Sheet1")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:AB" & lRow)
But if you want to use B1 as your rng you can replace your line, rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select with this line...
rng.Range(Cells(2, 2), Cells(rng.Rows.Count, 2)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
You are trying to select from a single cell range.
You should do instead:
Sub delete_rows_range()
'Application.ScreenUpdating = False
Dim rng, Rng_del As Range
Dim leg As Range
Set leg = Worksheets("Sheet1").Range("AB1")
Set rng = Worksheets("Sheet1").Range("B1")
If Worksheets("Sheet1").AutoFilterMode = True Then
Worksheets("Sheet1").AutoFilter.ShowAllData
End If
rng.Select
rng.AutoFilter Field:=2, Criteria1:=leg
'rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.delete
Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible).Rows(2).Select
Worksheets("Sheet1").AutoFilterMode = False
End Sub
Related
How do I change the first 3 characters and "CLEARANCE" Font to BOLD of cells containing "T##-" and loop it until the last row of STANDARD and NON-STANDARD tables
Sub Formatting()
Dim StartCell As Range
Set StartCell = Range("A15")
Dim myList As Range
Set myList = Range("A15:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim x As Range
For Each x In myList
'myList.ClearFormats
x.Font.Bold = False
If InStr(1, x.Text, "CLEARANCE") > 0 Or InStr(1, x.Text, "clearance") > 0 Then
x.Font.Bold = True
Else
x.Font.Bold = False
End If
Next
For Each x In myList
'myList.ClearFormats
x.Font.Bold = False
If InStr(1, x.Text, "T*") > 0 Then
x.Font.Bold = True
Else
x.Font.Bold = False
End If
Next
End Sub
ORIG
FORMATTED
Here is one way to achieve what you want which I feel is faster (I could be wrong). This way lets Excel do all the dirty work :D.
Let's say our data looks like this
LOGIC:
Identify the worksheet you are going to work with.
Remove any autofilter and find last row in column A.
Construct your range.
Filter the range based on "=T??-*" and "=*CLEARANCE*".
Identify the filtered range.
Check if there was anything filtered and if it was, then do a Find and Replace
Search for "CLEARANCE" and replace with bold tags around it as shown in the code.
Loop through the filtered range to create an html string and then copy to clipboard
Finally paste them back.
CODE:
Is this what you are trying? I have commented the code so you should not have a problem understanding it but if you do them simply ask :)
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range, rngFinal As Range, aCell As Range
Dim htmlString As Variant
'~~> Set this to the relevant Sheet
Set ws = Sheet1
With ws
'~~> Remove any autofilter
.AutoFilterMode = False
'~~> Find last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Construct your range
Set rng = .Range("A1:A" & lRow)
'~~> Filter the range
With rng
.AutoFilter Field:=1, Criteria1:="=T??-*", _
Operator:=xlAnd, Criteria2:="=*CLEARANCE*"
'~~> Set the filtered range
Set rngFinal = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
End With
'~~> Check if there was anything filtered
If Not rngFinal Is Nothing Then
rngFinal.Replace What:="CLEARANCE", Replacement:="<b>CLEARANCE</b>", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'~~> Loop through the filtered range and add
'~~> ending html tags and copy to clipboard and finally paste them
For Each aCell In rng.SpecialCells(xlCellTypeVisible)
If aCell Like "T??-*" Then
htmlString = "<html><b>" & _
Left(aCell.Value2, 4) & "</b>" & _
Mid(aCell.Value2, 5) & "</html>"
With CreateObject("htmlfile")
With .parentWindow.clipboardData
Select Case True
Case Len(htmlString): .setData "text", htmlString
Case Else: .GetData ("text")
End Select
End With
End With
DoEvents
aCell.PasteSpecial xlPasteAll
End If
Next aCell
End If
'~~> Remove any filters
ws.AutoFilterMode = False
End Sub
OUTPUT:
NOTE: If you want to bold either of the text when one of them is absent then change Operator:=xlAnd to Operator:=xlOr in the above code.
I thought I'd chuck in this solution based on regex. I was fiddling around a long time trying to use the Submatches attributes, but since they do not have the FirstIndex() and Lenght() properties, I had no other option than just using regular matching objects and the Like() operator:
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim rng As Range, cl As Range, lr As Long
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:A" & lr)
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\bCLEARANCE\b"
For Each cl In rng
If cl.Value Like "T[0-9][0-9]-*" Then
cl.Characters(0, 3).Font.Bold = True
If .Test(cl.Value) Then
Set M = .Execute(cl.Value)
cl.Characters(M(0).firstindex + 1, M(0).Length).Font.Bold = True
End If
End If
Next
End With
End Sub
The Like() operator is there just to verify that a cell's value starts with a capital "T", two digits followed by an hyphen. This syntax is close to what regular expressions looks like but this can be done without a call to the regex-object.
When the starting conditions are met, I used a regex-match to test for the optional "CLEARANCE" in between word-boundaries to assert the substring is not part of a larger substring. I then used the FirstIndex() and Lenght() properties to bold the appropriate characters.
The short and easy, but not fast and flexible approach. "Bare minimum"
No sheet specified, so uses active sheet. Will ignore multiple instances of "CLEARANCE", will loop everything (slow), ingores starting pattern (only cares if it starts with "T"), doesn't remove any bold text from things that shouldn't be bold.
Sub FormattingLoop()
Dim x As Range
For Each x In Range("A15:A" & Cells(Rows.Count, "A").End(xlUp).Row)
If Left(x, 1) = "T" Then x.Characters(, 3).Font.FontStyle = "Bold"
If InStr(UCase(x), "CLEARANCE") > 0 Then x.Characters(InStr(UCase(x), "CLEARANCE"), 9).Font.FontStyle = "Bold"
Next x
End Sub
I have the two Macro's which filters a worksheet column by date and then delete's the irrelevant columns.
However, it is very buggy and I need some help to correct that please.
This is what the second Macro is supposed to do:
1) Simply delete the visible rows after the filter is applied, except the first row (headers) - Currently, it deletes ALL visible rows including the first row, even though I have the Offset function in my code.
2) Remove all filters - This is working fine now
Sub DeleteVisibleRows()
Dim ws1 As Worksheet
Dim WorkRng As Range
Set ws1 = ActiveWorkbook.Sheets("Consolidated")
On Error Resume Next
Set WorkRng = Application.Selection
Application.ScreenUpdating = False
With ws1
WorkRng.Offset(1, 0).Rows.SpecialCells(xlCellTypeVisible).EntireRow.Delete
ws1.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
SpecialCells will work like the previous answer.
Sub Button1_Click()
Dim sh As Worksheet, rng As Range, LstRw As Long
Set sh = Sheets("Sheet1")
With sh
LstRw = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:A" & LstRw).SpecialCells(xlCellTypeVisible)
rng.EntireRow.Delete
.AutoFilterMode = False
End With
End Sub
Deleting rows of filtered data is something I needed time to time while working with tables in excel, but I could never trust a macro when it comes to deleting important stuff. If you still want to use it, this might work for you:
Sub DeleteVisibleRows()
Dim ws As Worksheet
Dim lastrow As Long, i As Long
Set ws = ThisWorkbook.Worksheets("Consolidated")
With ws
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
For i = lastrow To 2 Step -1 'To 2 Assuming first row contains headers
If .Rows(i).Hidden = False Then
.Rows(i).Delete
End If
Next
.ShowAllData 'remove filtered data
End With
End Sub
If you're using SELECTION there's no need to define the worksheet. Everything you need is relevant to your selection - your selection may not be on the Consolidated worksheet, it will always be on the parent object of your selection though.
The code below assumes you have a filter applied - if it isn't then everything below the heading gets deleted.
Public Sub DeleteVisibleRows()
Dim WorkRng As Range
Set WorkRng = Selection
With WorkRng
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
WorkRng.Parent.AutoFilterMode = False
End Sub
Edit: That code's too long, I'll get rid of some of the junk.
Public Sub DeleteVisibleRows()
With Selection
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.Parent.AutoFilterMode = False
End With
End Sub
I want to filter a report that may or may not have five keywords in Column B (red, blue, orange, green and yellow) These keywords are associated with numbers in a different column
I want to take the sum of the column associated with each keyword on the generated report
However, the report may or may not have all five keywords; day over day may be different, with or without yellow for instance
I took the sum of the first keyword (a criterion) in Column C to paste elsewhere and it works!
But once I search for the second keyword an error occurs : This can't be applied to a single cell, select a single cell in a range (Run-time error 1004) . Any thoughts?
Second question is how do set my range (C2:C1000) and (B2:B1000) and for all filtered numbers in column C and keywords in column B, since I can have over 1000 rows or rows whose location is beyond 1000
Set rng = ws.Range("C1:C" & lastrow) 'but to no avail
Sub filterVBA()
Dim lastrow As Long
Dim visibleTotal As Long
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets("Sheet1")
Set rng = ws.Range("C2:C1000")
Columns("B:B").Select
Selection.AutoFilter
ActiveSheet.Range("B2:B1000").AutoFilter Field:=1, Criteria1:="red"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A1").Value = visibleTotal
Columns("B:B").Select
Selection.AutoFilter
ActiveSheet.Range("B2:B1000").AutoFilter Field:=1, Criteria1:="blue"
Windows("Book6").Activate
Range("A2").Value = visibleTotal
End Sub
There are a number of issues here.
Use of Select gives unexpected results (the second Filter will be applied to Windows("Book6")). Use Variables to reference the sheets and ranges.
Resetting the AutoFilter is fragile, if one doesn't already exists it will actually set a filter. Detect if a Filter exists before clearing it.
Clean up range selection.
Missing visibleTotal = after second filter
Sub filterVBA()
Dim visibleTotal As Long
Dim wsTable As Worksheet
Dim wsReport As Worksheet
Dim rTable As Range
Dim rReport As Range
'Get reference to Table
Set wsTable = ThisWorkbook.Sheets("Sheet1")
With wsTable
Set rTable = .Range("B2", .Cells(.Rows.Count, "C").End(xlUp))
End With
'Get Reference to Reult sheet
Set wsReport = Application.Workbooks("Book6").ActiveSheet
Set rReport = wsReport.Cells(1, 1)
'Clear Filter if it exists
If wsTable.AutoFilterMode Then
rTable.AutoFilter
End If
'Set Filter
rTable.AutoFilter Field:=1, Criteria1:="red"
visibleTotal = Application.WorksheetFunction.Sum(rTable.Columns(2).SpecialCells(xlCellTypeVisible))
'Alternative formula
'visibleTotal = Application.WorksheetFunction.Subtotal(109, rTable.Columns(2))
'Report result
rReport.Value = visibleTotal
Set rReport = rReport.Offset(1, 0)
'Next Filter
rTable.AutoFilter Field:=1, Criteria1:="white"
visibleTotal = Application.WorksheetFunction.Sum(rTable.Columns(2).SpecialCells(xlCellTypeVisible))
rReport.Value = visibleTotal
Set rReport = rReport.Offset(1, 0)
End Sub
Note on why there is no Error Handling around SpecialCells
Because the range SpecialCells is applied to includes the header row, and a AutoFilter never hides the header, in this case SpecialCells will always return a result .
Thanks for your feedback Chris
I got my answer looking like this and works well:
Sub filterVBA()
Dim rng As Range
Dim ws As Worksheet
Dim visibleTotal As Long
Set ws = ThisWorkbook.Sheets(1)
Set rng = ws.Range("D:D")
If ws.FilterMode = True Then
ws.ShowAllData
End If
Application.ScreenUpdating = False
ws.Range("C:C").AutoFilter Field:=1, Criteria1:="Yellow"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A1").Value = visibleTotal
ws.Range("C:C").AutoFilter Field:=1, Criteria1:="Red"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A5").Value = visibleTotal
ws.Range("C:C").AutoFilter Field:=1, Criteria1:="Green"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A10").Value = visibleTotal
ws.Range("C:C").AutoFilter Field:=1, Criteria1:="Blue"
visibleTotal = Application.WorksheetFunction.Sum(rng.SpecialCells(xlCellTypeVisible))
Windows("Book6").Activate
Range("A15").Value = visibleTotal
If ws.FilterMode = True Then
ws.ShowAllData
End If
Application.ScreenUpdating = True
End Sub
I have some data that has both words and values in cells and I am trying to delete the rows that don’t have values in the cells. My code works now if all of the numbers are negative but if there are positive numbers then my code won’t work. How do I fix this?
Sub tval
Dim s As Long
Dim LastRow As Long
S=2
LastRow= cells.find(“*”,[A1],,, xlByRows,xlPreviousRow).row
Do until s>LastRow
DoEvents
If InStr(1,Cells(s,4), “-“) > 0 Then
S=s+1
Else
Cells(s,4).EntireRow.Delete
LastRow=LastRow -1
End if
Loop
End sub
When deleting rows, you should always start from the end.
Sub tval
Dim s As Long
Dim LastRow As Long
LastRow= Cells(Rows.Count, 1).End(xlUp).Row
For s= LastRow to 2 Step -1
If Not IsNumeric(Cells(s,4)) then
Cells(s,4).EntireRow.Delete
End if
Next s
End sub
This should work for you:
Sub tgr()
Dim ws As Worksheet
Dim rTextConstants As Range
Dim rTextFormulas As Range
Dim rCombined As Range
Set ws = ActiveWorkbook.ActiveSheet
'Exclude row 1 so that only text values found in rows 2+ are found
With ws.Range("A2", ws.Cells(ws.Rows.Count, ws.Columns.Count))
On Error Resume Next 'prevent error if no cells found
Set rTextConstants = .SpecialCells(xlCellTypeConstants, xlTextValues)
Set rTextFormulas = .SpecialCells(xlCellTypeFormulas, xlTextValues)
On Error GoTo 0 'remove on error resume next condition
End With
If Not rTextConstants Is Nothing Then Set rCombined = rTextConstants
If Not rTextFormulas Is Nothing Then
If rCombined Is Nothing Then Set rCombined = rTextFormulas Else Set rCombined = Union(rCombined, rTextFormulas)
End If
If Not rCombined Is Nothing Then
rCombined.EntireRow.Delete
Else
MsgBox "No cells containing text found in sheet '" & ws.Name & "'", , "Error"
End If
End Sub
May I suggest a bit of a different approach:
Before:
Code:
Dim RNG1 As Range, RNG2 As Range
Option Explicit
Sub TestCase()
With ActiveWorkbook.Sheets(1)
Set RNG1 = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
If RNG1.SpecialCells(xlCellTypeConstants, 1).Count <> RNG1.Cells.Count Then
Set RNG2 = Application.Intersect(RNG1, RNG1.SpecialCells(xlCellTypeConstants, 2))
RNG2.EntireRow.Delete
End If
End With
End Sub
After:
You'll need to change this around to suit your range obviously. It should be a good starting point nonetheless.
You can also use AutoFilter to filter the numbers, and delete the visible cells to accomplish this task. The code accounts for a header row.
With ThisWorkbook.Sheets("Sheet1")
With .Range("A1").CurrentRegion
.AutoFilter
.AutoFilter Field:=4, Criteria1:="<>*"
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With
End With
I have data from A to F column and I want to filter in E column and delete the entire row which contains # and only numbers. (Check image). I used the code and it works for #, but numbers not. In filter the 'Number filter' is not availble so i cant record in macro.
How to change the code? Help me, please.
Sub Macro3()
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Sheet1")
Set rng1 = ws.Range(ws.[A2], ws.Cells(Rows.Count, "F").End(xlUp))
With ActiveSheet
.AutoFilterMode = False
rng1.AutoFilter Field:=5, Criteria1:="#"
rng1.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
End With
End Sub
You can use Criteria1:=">=0" to find all numbers.
rng1.AutoFilter Field:=5, Criteria1:=">=0", Operator:=xlAnd
Dim RowsToDelete As Range
On Error Resume Next
Set RowsToDelete = rng1.Resize(RowSize:=rng1.Rows.Count - 1).Offset(RowOffset:=1).SpecialCells(xlCellTypeVisible).EntireRow
On Error GoTo 0
If Not RowsToDelete Is Nothing Then RowsToDelete.Delete
Note:
rng1.Resize(RowSize:=rng1.Rows.Count - 1).Offset(RowOffset:=1)
removes the header from rng1 selection
.SpecialCells(xlCellTypeVisible).EntireRow
selects only the visible cells of the filtered range.