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
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 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
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.
I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub
I have an excel table with rows of data. The column J contains various descriptions of goods. I need to search all the rows in this column for the word LATEX and when it is found, copy ONLY this word to the column A on the same sheet on the same row. I was trying to find a solution and came up with this macro using Autofilter, but it is not working properly. Can you please help me?
Sub FilterAndCopy()
Dim dataWs As Worksheet
Dim copyWs As Worksheet
Dim totRows As Long
Dim lastRow As Long
Set dataWs = Worksheets("Massiv")
Set copyWs = Worksheets("Massiv")
With dataWs
.AutoFilterMode = False
With .Range("J:J")
.AutoFilter Field:=1, Criteria1:="LATEX"
End With
End With
totRows = dataWs.Range("J:J").Rows.count
lastRow = dataWs.Range("J" & totRows).End(xlUp).Row
dataWs.Range("J:J" & lastRow).Copy
copyWs.Range("A6").PasteSpecial Paste:=xlPasteValues
dataWs.AutoFilterMode = False
With the following changes, your code should work. I've noted the changes in the comments in the code.
With dataWs
.AutoFilterMode = False
With .Range("J:J")
'Use wildcard to search for word LATEX within contents of column J cells
.AutoFilter Field:=1, Criteria1:="*LATEX*"
End With
End With
totRows = dataWs.Range("J:J").Rows.Count
lastRow = dataWs.Range("J" & totRows).End(xlUp).Row
'After filtering, select the visible cells in column A...
Set rng = dataWs.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible)
'... and set their values to "LATEX"
rng.Value = "LATEX"
dataWs.AutoFilterMode = False