I have the below code which looks for matroux in a row which works great but now I want to change it that once it finds and filters matroux, it needs to go to another column and only show numbers higher than 0.
If I remove the second filter it filters matroux perfect, but the below code does not filter matroux then the second column.
Here is what I have tried.
Sub FindMatt()
Const Login As String = "matroux"
Const Header As String = "T*M*"
Const Hours As String = "Allocated hours"
Const HeaderRow As Long = 3
Dim ws As Worksheet: Set ws = ActiveSheet
If ws.FilterMode Then ws.ShowAllData
Dim Col As Variant
Dim Col2 As Variant ' it could be an error value hence 'As Variant'
Col = Application.Match(Header, ws.Rows(HeaderRow), 0)
Col2 = Application.Match(Hours, ws.Rows(HeaderRow), 0)
If IsError(Col) Then ' this doesn't work with 'WorksheetFunction.Match'
MsgBox "Header not found.", vbCritical
Exit Sub
End If
If IsError(Col2) Then ' this doesn't work with 'WorksheetFunction.Match'
MsgBox "Hours not found.", vbCritical
Exit Sub
End If
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
Dim LastRow2 As Long: LastRow2 = ws.Cells(ws.Rows.Count, Col2).End(xlUp).Row
If LastRow <= HeaderRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
If LastRow2 <= HeaderRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
With ws.Range(ws.Cells(HeaderRow, Col), ws.Cells(LastRow, Col))
.AutoFilter 1, Login
End With
With ws.Range(ws.Cells(HeaderRow, Col2), ws.Cells(LastRow2, Col2))
.AutoFilter 1, “>0”
End With
End Sub
Related
I have the below code which looks at the current open sheet, looks for column Team Manager and filters text. The headers are on the 3rd row and the column Team Manager might change to TM hence me using wild card.
For some reason, it is not working. Am i missing something?
Here is my code
Option Explicit
Sub FindMatt()
Dim ws As Worksheet
Dim LastRow As Long, col As Long
Const login = "matroux"
Const header = "T*M*"
Set ws = ActiveSheet
col = Application.WorksheetFunction.Match(header, ws.Range("3:3"), 0)
LastRow = ws.Cells(Rows.Count, col).End(xlUp).Row
With ws.Range(ws.Cells(3, col), ws.Cells(LastRow, col))
.AutoFilter 1, login
End With
End Sub
AutoFilter Data
I'm not sure why your code didn't work (but works now; my guess would be you had another filter active) but the following illustrates what could go wrong. Also, you need to make sure the correct worksheet is active when using ActiveSheet.
Sub FindMatt()
Const Login As String = "matroux"
Const Header As String = "T*M*"
Const HeaderRow As Long = 3
Dim ws As Worksheet: Set ws = ActiveSheet
If ws.FilterMode Then ws.ShowAllData
Dim Col As Variant ' it could be an error value hence 'As Variant'
Col = Application.Match(Header, ws.Rows(HeaderRow), 0)
If IsError(Col) Then ' this doesn't work with 'WorksheetFunction.Match'
MsgBox "Header not found.", vbCritical
Exit Sub
End If
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
If LastRow <= HeaderRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
With ws.Range(ws.Cells(HeaderRow, Col), ws.Cells(LastRow, Col))
.AutoFilter 1, Login
End With
End Sub
So I have designed this code to insert new entries into my master Database Log but when I run the code it is much too slow.
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim LR As Long, i As Long, iRow As Long
Set ws = ThisWorkbook.Worksheets("Data Entry")
With ws
LR = .Cells(Rows.Count, 1).End(xlUp).Row
If 2 > LR Then Exit Sub
iRow = 3
For i = 1 To LR
If .Cells(i, 1).DisplayFormat.Interior.Color = RGB(217, 230, 251) Then
Worksheets("Call Log").Rows("3:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(i, 1).Resize(1, 7).Copy ThisWorkbook.Worksheets("Call Log").Cells(iRow, "A")
End If
Next i
End With
Set ws = Nothing
End Sub
As you can see, my code goes through the range, determines if it matches my criteria (in this case the color of the cell) and then Inserts a row in the destination Worksheet and copies the data into that newly created row over and over until it finishes. I've thought of maybe having it select all of the necessary cells, copy and then insert them all at once into the destination worksheet, but I'm not sure how to go about that.
Any help is greatly appreciated!
One of the things you are doing obsoletely, is copying something to the clipboard, while this is not necessary: instead of
Range("<somewhere>").Copy
Range("<elsewhere>").Paste
You might simply do:
Range("<elsewhere>".Value = Range("<somewhere>").Value
It's always a good idea to turn off screen updating and set calculations to manual (unless you need it)
Application.SceenUpdating = false
Application.calculations = xlmanual
Then set them back to true and xlautomatic at the end of the code.
Not sure if the syntaxes is correct, I'm typing from my phone
If you absolutely need to copy the source formatting of the cells also, then you could use a filter and then copy only the visible cells, all in one go. Something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
Dim filterColor As Long
'
'Filter Range
filterColor = RGB(217, 230, 251)
With Range(shtData.Cells(1, 1), shtData.Cells(lastRow, 1))
.AutoFilter Field:=1, Criteria1:=filterColor, Operator:=xlFilterCellColor
End With
'
Dim rng As Range
Const lastCol As Long = 7
Dim firstRow As Long
'
'Get filtered range
'First row remains visible regardless of filter. Check it
If shtData.Cells(1, 1).Cells(1, 1).DisplayFormat.Interior.Color <> filterColor Then
firstRow = 2
Else
firstRow = 1
End If
On Error Resume Next
Set rng = Range(shtData.Cells(firstRow, 1), shtData.Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then Exit Sub 'Nothing meets criteria
'
Dim tempArea As Range
Dim rCount As Long
'
'Get required rows count
For Each tempArea In rng.Areas
rCount = rCount + tempArea.Rows.Count
Next tempArea
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + rCount - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
rng.Copy shtLog.Cells(iRow, 1)
'
'Remove filter
rng.AutoFilter
End Sub
But, if you don't care about source formatting then you could use something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
'Read data in array (super fast)
Dim rng As Range
Dim arrData() As Variant
Const lastCol As Long = 7
'
Set rng = Range(shtData.Cells(1, 1), shtData.Cells(lastRow, lastCol))
arrData = rng.Value2
'
'Store relevant row numbers
Dim collRows As New Collection
Dim i As Long
Dim filterColor As Long: filterColor = RGB(217, 230, 251)
'
For i = LBound(arrData) To UBound(arrData)
If rng.Cells(i, 1).DisplayFormat.Interior.Color = filterColor Then
collRows.Add i
End If
'
'I am not a fan of using colors for filtering. It's much faster to have a separate
' column (indicator column) that can be used for that. This way we could do
' something like: If arrData(i, indCol) = expectedValue Then ...
' which is much faster than accesing cells
Next i
'
'Prepare data for writing
Dim arrFiltered() As Variant
ReDim arrFiltered(1 To collRows.Count, 1 To lastCol)
Dim r As Variant
Dim c As Long
'
i = 0
For Each r In collRows
i = i + 1
For c = 1 To lastCol
arrFiltered(i, c) = arrData(r, c)
Next c
Next r
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + collRows.Count - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'
'Write
With Range(shtLog.Cells(iRow, 1), shtLog.Cells(iRow + collRows.Count - 1, lastCol))
.Value2 = arrFiltered
End With
End Sub
Private Function GetWorksheet(ByVal sheetName As String, ByVal book As Workbook) As Worksheet
On Error Resume Next
Set GetWorksheet = book.Worksheets(sheetName)
On Error GoTo 0
End Function
The above is rushed code but proves some ways of doing the task. Other things that need to be considered are:
Are the worksheets protected? if yes, filtering and inserting rows can be an issue
Inserting rows will fail if the rows are intersecting multiple dynamic tables (listobjects)
Code needs to be changed if data doesn't start on row 1 in the source
and probably others that don't come to mind right now
Want to find duplicates in a column in excel and want to popup a msgbox upon finding even 1 duplicate and it shouldn't keep on popping messages if it finds more than one duplicate.
Also, if i can use two column cell values and use that together to find duplicates, this would be also helpful.
Sub ColumnDuplicates()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("A1:A" & lastRow), 0)
If iCntr <> matchFoundIndex Then
MsgBox ("There are duplicates in Column A")
End If
End If
Next
MsgBox ("No Duplicates in Column A")
End Sub
Expecting to print message saying that column A has duplicates or does not have duplicates
What about the use of EVALUATE?
Public Sub Test()
With ThisWorkbook.Sheets("Sheet1")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
If .Evaluate("=Max(countif(A1:A" & lr & ",A1:A" & lr & "))") > 1 Then
MsgBox "Duplicates!"
Else
MsgBox "No Duplicates!"
End If
End With
End Sub
Or, parameterized:
Public Sub Test(ByVal sheet As Worksheet, ByVal columnHeading As String)
With sheet
lr = .Cells(.Rows.Count, columnHeading).End(xlUp).Row
If .Evaluate("=Max(countif(" & columnHeading & "1:" & columnHeading & lr & "," & columnHeading & "1:" & columnHeading & lr & "))") > 1 Then
MsgBox "Duplicates!"
Else
MsgBox "No Duplicates!"
End If
End With
End Sub
Now you can invoke it like this:
Test Sheet1, "A" ' find dupes in ThisWorkbook/Sheet1 in column A
Test Sheet2, "B" ' find dupes in ThisWorkbook/Sheet2 in column B
Test ActiveWorkbook.Worksheets("SomeSheet"), "Z" ' find dupes in "SomeSheet" worksheet of whatever workbook is currently active, in column Z
Throw your values in a dictionary
Sub ColumnDuplicates()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
lastRow = Range("A65000").End(xlUp).Row
Set oDictionary = CreateObject("Scripting.Dictionary")
For iCntr = 1 To lastRow
If Cells(iCntr, 1) <> "" Then
If oDictionary.Exists(Cells(iCntr, 1).Value) Then
MsgBox ("There are duplicates in Column A")
Exit Sub
Else
oDictionary.Add Cells(iCntr, 1).Value, Cells(iCntr, 1).Value
End If
End If
Next
MsgBox ("No Duplicates in Column A")
End Sub
If you have Excel 2007+ then this will be faster. This code ran in 1 sec for 200k rows
Sub Sample()
Debug.Print Now
Dim ws As Worksheet
Dim wsTemp As Worksheet
Set ws = Sheet1
Set wsTemp = ThisWorkbook.Sheets.Add
ws.Columns(1).Copy wsTemp.Columns(1)
wsTemp.Columns(1).RemoveDuplicates Columns:=1, Header:=xlNo
If Application.WorksheetFunction.CountA(ws.Columns(1)) <> _
Application.WorksheetFunction.CountA(wsTemp.Columns(1)) Then
Debug.Print "There are duplicates in Col A"
Else
Debug.Print "duplicates found in Col A"
End If
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Debug.Print Now
End Sub
I used the below code to generate 200k records in Col A
Sub GenerateSampleData()
Range("A1:A200000").Formula = "=Row()"
Range("A1:A200000").Value = Range("A1:A200000").Value
Range("A10000:A20000").Value = Range("A20000:A30000").Value
End Sub
Code execution
I am attempting to build a loop that searches through headers and finds a contained value, In this case, "Avg". If the value is found it will work down the column and apply a format based on a comparison to another column. I am trying to convert my cell variable in the For loop (Z) into a column address so I can use to control my ws.Cells() value in the next loop.
Any help is greatly appreciated, thanks!!!!
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
Dim Z As Range
lastRow = ws.Cells(ws.Rows.Count, "I").End(xlUp).Row
For Each Z In Range("I1:BM1").Cells
If InStr(1, Z.Value, "Avg") Then
For i = 2 To lastRow 'loop from row 2 to last
If ws.Cells(i, 8) - ws.Cells(i, Z) < 0 Then
ws.Cells(i, Z).Interior.ColorIndex = 4
End If
Next i
End If
Next Z
End Sub
It's not exactly clear to me what you want - but from the title it appears you want to get the column number based on the header text? If so, this will do that:
Private Function GetColumn(headerName As String) As Integer
Dim col As Integer
GetColumn = 0
For col = 1 To ActiveSheet.UsedRange.Columns.Count
If ActiveSheet.Cells(1, col).Value = headerName Then
GetColumn = col
Exit For
End If
Next col
End Function
Find Header and Format Cells
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: In a column range specified by its header,
' highlights the cells matching a condition.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub HighlightBelowAverages()
' Define constants.
Const PROC_TITLE As String = "Highlight Below-Averages"
Const COMPARE_COLUMN As String = "H"
Const AVG_SEARCH_COLUMNS As String = "I:BM"
Const AVG_COLUMN_HEADER As String = "Avg"
Const AVG_COLOR_INDEX As Long = 4 ' Bright Green
' Reference the Search range.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
Dim srg As Range
' It is NOT assumed that the used range starts in row '1'.
Set srg = Intersect(ws.UsedRange, ws.Range(AVG_SEARCH_COLUMNS))
If srg Is Nothing Then
MsgBox "The Average search columns '" & AVG_SEARCH_COLUMNS _
& "' are not part of the used range.", vbCritical, PROC_TITLE
Exit Sub
End If
' Find the Average header cell.
Dim ahCell As Range
With srg
Set ahCell = .Find(AVG_COLUMN_HEADER, _
.Cells(.Rows.Count, .Columns.Count), xlFormulas, xlWhole, xlByRows)
End With
If ahCell Is Nothing Then
MsgBox "Header '" & AVG_COLUMN_HEADER & "' not found.", _
vbCritical, PROC_TITLE
Exit Sub
End If
' Reference the Average (single-column) range.
Dim afCell As Range: Set afCell = ahCell.Offset(1)
Dim alCell As Range
Set alCell = Intersect(srg.Rows(srg.Rows.Count), ws.Columns(ahCell.Column))
' It IS assumed that the data has one row of headers.
If afCell.Row > alCell.Row Then
MsgBox "No data found.", vbCritical, PROC_TITLE
Exit Sub
End If
Dim arg As Range: Set arg = ws.Range(afCell, alCell)
' Reference the Compare (single-column) range.
Dim crg As Range
' It is NOT assumed that the used range starts in column 'A'.
Set crg = Intersect(arg.EntireRow, ws.Columns(COMPARE_COLUMN))
' Highlight the cells.
Application.ScreenUpdating = False
arg.Interior.ColorIndex = xlNone
Dim aCell As Range, cCell As Range, r As Long
For Each aCell In arg.Cells
r = r + 1
Set cCell = crg.Cells(r)
If cCell.Value < aCell.Value Then ' Compare is less than Average
aCell.Interior.ColorIndex = AVG_COLOR_INDEX
End If
Next aCell
Application.ScreenUpdating = True
' Inform.
MsgBox "Below-averages highlighted.", vbInformation, PROC_TITLE
End Sub
Sub Test1()
Dim LastRow As Range
Dim cfind As Range
'Set WS = ActiveWorkbook.Worksheets("Report")
'With WS
'Set cfind = Cells.Find(what:="Order Status", lookat:=xlWhole, MatchCase:=False)
'End With
LastRow = Cells(Rows.Count, "C").End(xlUp).Row
For i = LastRow To 2 Step -1
If Range("C" & i).Value = "Canceled" Then
Range("C" & i).EntireRow.Delete
End If
Next i
End Sub
I am trying to delete the rows which has a value "Canceled" in a column which has a header "Order Status". I am currently using the column number or name. I am not sure how to use column header (Order Status) to delete the rows.
Can someone help me?
Your LastRow was a range object, should have been a long.
Sub Test1()
'not necessary now but should have been a long
'Dim LastRow As long
'not necessary now
'Dim cfind As Range
Dim col As Variant
With ActiveWorkbook.Worksheets("Report")
col = Application.Match("Order Status", .Rows(1), 0)
If Not IsError(col) Then
For i = .Cells(.Rows.Count, col).End(xlUp).Row To 2 Step -1
If .Cells(i, col).Value = "Canceled" Then
.Rows(i).EntireRow.Delete
End If
Next i
else
msgbox "no 'Order Status' here"
End If
end with
End Sub