Need formula to match text from one column to text in different worksheet and count the highlighted cells. This is similar to doing a sumif, but instead of returning a numerical value in a static column, I will return the count of highlighted cells.
I have successfully written the VBA to count the highlighted cells in a given column, but now must do a match of names. Meaning, if name in column A1:A50 matches name in Sheet2 Column J1:J52, then return a count of highlighted cells in sheet 2 column X.
Formula to count highlighted cells: countbycolor('sheet2'!J4:J1847,A52)
VBA:
Function CountByColor(InputRange As Range, ColorRange As Range) As Long
Dim cl As Range, TmpCount As Long, ColorIndex As Integer
Application.Volatile
ColorIndex = ColorRange.Interior.ColorIndex
TmpCount = 0
On Error Resume Next
For Each cl In InputRange.Cells
If cl.Interior.ColorIndex = ColorIndex _
Then TmpCount = TmpCount + 1
Next cl
CountByColor = TmpCount
End Function
Adding a parameter for the criteria range and implementing Application.Countif should be sufficient.
Function CountByColorAndName(InputRange As Range, NameRange As Range, ColorRange As Range) As Long
Dim cl As Range, TmpCount As Long, ColorIndex As Integer
Application.Volatile
ColorIndex = ColorRange.Interior.ColorIndex
TmpCount = 0
On Error Resume Next
For Each cl In InputRange.Cells
If cl.Interior.ColorIndex = ColorIndex and _
cbool(application.countif(NameRange , cl.value)) then _
TmpCount = TmpCount + 1
Next cl
CountByColor = TmpCount
End Function
Sample syntax:
=CountByColorAndName('sheet2'!J4:J1847, A1:A50, A52)
There is a little confusion as your description of the situation refers to both Sheet2 Column J1:J52 and 'sheet2'!J4:J1847. If this isn't appropriate, please clarify.
The MATCH function is actually more efficient than the COUNTIF function, both on the worksheet and within VBA. This should reduce calculation load some.
For Each cl In InputRange.Cells
If cl.Interior.ColorIndex = ColorIndex then _
if not iserror(application.match(cl.value, NameRange , 0)) then _
TmpCount = TmpCount + 1
Next cl
Related
Attached is my code so far. My issue is that I can't seem to get the macro to compare only whole words sheet(2) column B activecell (which contains more than one word within the cell) to the range (column A) in sheet(1) - which is a list of whole words (pictured below). Everything else in the code works fine but at present it only works for exact matches?
I have tried using the wildcard approach but it seems to match any characters whereas I need it to compare whole words from the sentences (which are varying each time in the active cell).
Any tips on what I can add so that the countif function finds whole words instead of characters etc? The same problem is for the Find function, where it will only find the exact match and return errors if it doesn't find exactly that.
Sub FMEATest1()
Dim count As Integer
Dim count2 As Integer
Dim n As Integer
Dim m As Integer
Dim FML As Range
Dim i As Range
'Dim m As Integer
Dim a As Range
Dim b As Integer
Dim FML2 As Range
Dim WrdArray() As String
Dim k As Range
Dim j As Range
Dim Splitsentence As Range
Worksheets(1).Activate
Range(("A1"), Range("A1").End(xlDown)).Select
Set FML = Selection
Worksheets(2).Activate
Range("B3").Activate
Do Until ActiveCell.value = ""
Set i = ActiveCell
WrdArray() = Split(i, , , vbTextCompare)
Set Splitsentence = WrdArray().value
count = Application.WorksheetFunction.CountIf(FML, Splitsentence)
'm = (ActiveCell.Row) + count - 1
n = Selection.Rows.count
Do Until n = (count)
ActiveCell.Offset(1, 0).EntireRow.Insert
Set a = Selection.Offset(1, 0)
ActiveCell.COPY
ActiveCell.Offset(1, 0).value = ActiveCell.value
ActiveCell.PasteSpecial
Range(i, a).Select
n = Selection.Rows.count
Loop
'Copying Failure Modes for each Keyword
Lookfor = ActiveCell.value & "*"
Worksheets(1).Activate
Cells.Find(What:=Lookfor, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False).Select
Set FML2 = Selection
Set j = ActiveCell
count2 = Application.WorksheetFunction.CountIf(FML2, j)
m = Selection.Rows.count
Do Until m = (count)
Set k = Selection.Offset(1, 0)
Range(j, k).Select
m = Selection.Rows.count
Loop
Selection.Offset(0, 1).COPY
Worksheets(2).Activate
ActiveCell.Offset(0, 1).PasteSpecial
ActiveCell.Offset(n, -1).Activate
Loop
End Sub
The difficulty is that the activecell contains a sentence and this sentence varies each time as in the example below, but I need the macro to match whole key words from column B in sheet(2) to Column A in sheet (1).
Can someone please make my images publically visible please?
So I would be looking for the code to be able to find the word "charge" from cell B3 out of the whole sentence (and get it to find it in column A of sheet(1)). And the word "Hold" from B4 from the whole sentence. These can change so much so I can't manually input them into the find function I need to reference the activecell.
The final solution of the code should give the following result (I've given two examples for "charge" and "hold"):
I have assumed data as outlined in the comments so you may have to amend sheet names and ranges. Also depending on what other data you have in your sheet it may need some adjustment for the output, but if you mock up an example based on your screenshots it should work as desired.
Sub x()
Dim v, vOut(), i As Long, j As Long, k As Long, va, r As Range, r1 As Long
'Assumes list of words in A1/B1 and down on "Sheet1"
Set r =Sheets("Sheet1").Range("A1").CurrentRegion
With Sheets("Sheet2") 'Assumes phrases in B1 and down on "Sheet2"
v = .Range("B1", .Range("B" & Rows.Count).End(xlUp)).Value
.Columns(2).ClearContents
End With
ReDim vOut(1 To UBound(v) * r.Rows.Count, 1 To 2)
For i = LBound(v, 1) To UBound(v, 1)
va = Split(v(i, 1))
For j = LBound(va) To UBound(va)
For r1 = 1 To r.Rows.Count
If LCase(Application.Trim(va(j))) = LCase(r.Cells(r1, 1)) Then
k = k + 1
vOut(k, 1) = v(i, 1)
vOut(k, 2) = r.Cells(r1, 2)
End If
Next r1
Next j
Next i
Sheets("Sheet2").Range("B1").Resize(k, 2) = vOut 'Puts results in B1/C1 and down on "Sheet2"
End Sub
How to find location of last cell from defined Range? Cell does not have to contain any data but must be most right and most down located cell from certain Range.
Set rngOrigin = wksOrigin.Cells(IntFirstRow, IntFirstColumn).CurrentRegion
I wish to receive
Cells(i,j)
Perhaps this is what you want:
Dim rngLastCell As Range
Set rngLastCell = rngOrigin(rngOrigin.Count)
maybe you're after this:
'absolute indexes from cell A1
With rngOrigin
i = .Rows(.Rows.count).row
j = .Columns(.Columns.count).Column
End With
'relative indexes from rngOrigin upleftmost cell
With rngOrigin
i = .Rows(.Rows.count).row - .Rows(1).row + 1
j = .Columns(.Columns.count).Column - .Columns(1).Column + 1
End With
I handled it in below code but your remarks were helpful. Thank you.
intLastRow = rngOrigin.Cells(1, 1).Row + rngOrigin.Rows.Count - 1
intLastCol = rngOrigin.Cells(1, 1).Column + rngOrigin.Columns.Count - 1
The answers given by others mostly work, but not if the region is a union of non-contiguous cells. Here is a version that works consistently for single and multi-area regions, contiguous and non-contiguous.
Function LastCellOfRange(rng As Excel.Range) As Excel.Range
Dim area As Excel.Range
Dim rowNum As Long
Dim maxRow As Long
Dim colNum As Long
Dim maxCol As Long
Dim areaIdx As Integer
Set LastCellOfRange = Nothing
maxRow = 0
maxCol = 0
For areaIdx = 1 To rng.Areas.Count
Set area = rng.Areas(areaIdx)
rowNum = area.Cells(area.Cells.Count).row
If (rowNum > maxRow) Then
maxRow = rowNum
End If
colNum = area.Cells(area.Cells.Count).Column
If (colNum > maxCol) Then
maxCol = colNum
End If
Next areaIdx
Set LastCellOfRange = rng.Worksheet.Cells(maxRow, maxCol)
Set area = Nothing
End Function
Use this to code find the last cell in a given range
Sub GetLastCellFromRange()
Dim rng As Range
Set rng = Range("$C$10:$E$20")
'Set rng = Range(Selection.Address) ' Use this line to select the range in worksheet
MsgBox "Last Cell of given range is : " & rng.Cells(rng.Rows.Count, rng.Columns.Count).Address
End Sub
I hope it will help you
you could try the following but it relies upon cells always being populated
rngOrigin.End(xlDown).End(xlRight)
or you could use the CurrentRegion and count the rows and columns and use Offset
Alternatively, you could use this construct which works even with ranges based on entire rows or entire columns.
Sub Test()
Dim rngOrigin As Excel.Range
Set rngOrigin = Range("$A$1:$D$6")
Dim rngLast As Excel.Range
Set rngLast = rngOrigin.Cells(rngOrigin.Cells.Count)
Debug.Print rngLast.Address
End Sub
Finally, for ranges with multiple areas you'll have to script against a range's Areas collection ...
Sub Test()
Dim rngOrigin As Excel.Range
Set rngOrigin = Range("$A$1:$D$6,$F$1:$G$6")
Debug.Print rngOrigin.Areas(1).Cells(rngOrigin.Areas(1).Cells.Count).Address
Debug.Print rngOrigin.Areas(2).Cells(rngOrigin.Areas(2).Cells.Count).Address
End Sub
Many answers here will work as long as the given range is continuous. This is what I would use for a range that you are absolutely sure is going to be continuous:
Sub test()
Dim myRng As Range, lastCell As Range
Set myRng = Range("A1:D4")
Set lastCell = myRng.Cells(myRng.Rows.Count, myRng.Columns.Count)
Debug.Print lastCell.Address 'returns $D$4
End Sub
For non-continuous, DB user10082797 gave a great solution, however their function fails when the ranges are positioned diagonal-up (for example, if you pass rng=A3:B4,C1:D2 in you will get D4 as the output which was not part of the original range.)
So the question becomes, what is the last cell in the range A3:B4,C1:D2? Is it B4 or D2? That's a decision for the programmer. Here is a function I wrote with the help of DB user10082797's function:
Function LastCellOfRange(rng As Range, Optional returnLastRow As Boolean = True) As Range
'returns the last cell in #rng.
'if #returnLastRow is TRUE, then the output will always be in the right most cell of the last row of #rng
'if #returnLastRow is FALSE, then the output will always be in the bottom most cell of the last column of #rng
'(#returnLastRow only matters for non-contiguous ranges under certain circumstances.)
'initialize variables
Dim area As Range, areaIdx As Long
Dim lastCellInArea As Range
'loop thru each area in the selection
For areaIdx = 1 To rng.Areas.Count
Set area = rng.Areas(areaIdx) 'get next area
Set lastCellInArea = area.Cells(area.Rows.Count, area.Columns.Count) 'get the last cell in the area
'if:
' the return is empty
' OR if the last row needs to be returned and this row is larger than the last area's
' OR if the last row needs to be returned and this row is the same as the last area's but has a larger column
' OR if the last column needs to be returned and this column is larger than the last area's
' OR if the last column needs to be returned and this column is the same as the last area's but has a larger row
'THEN:
' make this cell the return range
If LastCellOfRange Is Nothing Then
Set LastCellOfRange = lastCellInArea '(must be seperate from the other statment when its not set to anything)
ElseIf _
returnLastRow = True And lastCellInArea.Row > LastCellOfRange.Row _
Or returnLastRow = True And lastCellInArea.Row = LastCellOfRange.Row And lastCellInArea.Column > LastCellOfRange.Column _
Or returnLastRow = False And lastCellInArea.Column > LastCellOfRange.Column _
Or returnLastRow = False And lastCellInArea.Column = LastCellOfRange.Column And lastCellInArea.Row > LastCellOfRange.Row _
Then
Set LastCellOfRange = lastCellInArea
End If
Next areaIdx
End Function
You can use the function like this:
Sub test()
Dim myRng As Range
Set myRng = Range("A3:B4,C1:D2")
Debug.Print LastCellOfRange(myRng).Address 'returns $B$4
Debug.Print LastCellOfRange(myRng, False).Address 'returns $D$2
End Sub
In your case, since you want to find the cell to the most right and down in your wksOrigin (defined as Worksheet), you could use the SpecialCells(xlCellTypeLastCell) to get the last cell Row and Column.
i = wksOrigin.Cells.SpecialCells(xlCellTypeLastCell).Row ' <-- get last row number
j = wksOrigin.Cells.SpecialCells(xlCellTypeLastCell).Column ' <-- get last column number
If you want to debug your result, you can add:
MsgBox "Last row at " & i & ", last column at " & j
If you want the absolute last cell of a defined range, regardless of whether it has any content, here is a simple solution
Dim InputRng As Range 'define a range for the test'
Set InputRng = Range("$F$3:$F$15")
MsgBox InputRng(1).Address & ":" & InputRng(InputRng.Cells.Count).Address 'This would output the absolute address of defined range'
Hi I have been given a sheet with some formulas in them for example:
=SUM(D4:D1051) - can pretend this is in cells(1,1)
With VBA how can I pull out the row start and row end?
Ideally i would have lRowStart = 4 and lRowEnd = 1051 but I am not sure of the syntax to use to get this.
Something like this
for x = range("a1").Precedents(1).row to range("a1").Precedents(range("a1").Precedents.Count).row
If there are no formula in the range :)
or something along these lines.
Dim strFormula
Dim lngStartRow As Long
Dim lngEndRow As Long
strFormula = Replace(Replace(Cells(1, 1).Formula, "=SUM(", vbNullString), ")", vbNullString)
lngStartRow = Range(Split(strFormula, ":")(0)).Row
lngEndRow = Range(Split(strFormula, ":")(1)).Row
or even extract the range address then use foreach on the range .Rows, just no need for the split to get the range address.
You can get the cells that are referenced in the formula using .Precedents
Dim rng As Range
Dim rowStart As Long
Dim rowEnd As Long
On Error Resume Next 'in case there are no precedents
Set rng = Cells(1, 1).Precedents
On Error GoTo 0
If Not rng Is Nothing Then
rowStart = rng.Row 'or rng.Areas(1).Row (see edit)
rowEnd = rng.Row + rng.Rows.Count - 1 'or rng.Areas(1).Row and rng.Areas(1).Rows.Count
Else
rowStart = 0
rowEnd = 0
End If
Edit there are a few cases that are tricky. If the formula contains multiple references, e.g. =SUM(B1:B2) + SUM(D3:D4) you will get a union of ranges. The same is true if the cells that are referenced have references to other cells themselves.
In these cases, you can use .Areas to get the individual areas the range consists of. I'm not sure how they are ordered exactly but it seems that the "top-level" references are first. Example:
Dim rng As Range
Dim ar As Range
Range("A1").Formula = "=sum(B5:B7) + B1"
Range("B6").Formula = "=B3"
Set rng = Range("A1").Precedents
For Each ar In rng.Areas
Debug.Print ar.Address
Next ar
Output:
$B$5:$B$7
$B$1
$B$3
However be careful as areas will be combined if the are next to each other.
It also seems that it can't handle references to other sheets very well.
I used a conditional format =B2=MAX(Relative Range) to highlight across all rows the max value contained within them.
I'm trying to count how many instances of color X has appeared in this column.
i.e. Column A2:1000 - this would have 5 high-lighted instances.
Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean)
Dim rCell As Range
Dim lCol As Long
Dim vResult
lCol = rColor.Interior.ColorIndex
If SUM = True Then
For Each rCell In rRange
If rCell.Interior.ColorIndex = lCol Then
vResult = WorksheetFunction.SUM(rCell, vResult)
End If
Next rCell
Else
For Each rCell In rRange
If rCell.Interior.ColorIndex = lCol Then
vResult = 1 + vResult
End If
Next rCell
End If
ColorFunction = vResult
End Function
This is the code I have taken from http://www.extendoffice.com/documents/excel/1155-excel-count-sum-cells-by-color.html. The counting fails because of my conditional format. It reads the cells as being "white" because it doesn't interpret the conditional format.
Here's a snapshot of how some of the data is arranged for reference.
To determine Sum based conditional formatting rule with formula =B2=MAX(Relative Range):
Option Explicit
Public Function ColorFunction(rRange As Range, Optional getSum As Boolean = False)
Dim cel As Range, r As Long, c As String, ur As Range, lr As Long, v As Long
For Each cel In rRange
With cel
If Len(cel) > 0 And IsNumeric(cel) Then 'IsDate(cel)
If .FormatConditions.Count = 1 Then
If InStr(1, .FormatConditions.Item(1).Formula1, "#") = 0 Then
v = .Value2
c = Split(.Address(True, False), "$")(0)
lr = .Parent.UsedRange.Rows.Count
Set ur = .Parent.Range(c & "2:" & c & lr)
If WorksheetFunction.Max(ur) = v Then r = r + IIf(getSum, v, 1)
End If
End If
End If
End With
Next
ColorFunction = r
End Function
This code is very specific to your case:
it only works with one conditional formatting rule
that rule is MAX(range) and is hard-coded in main logic
it's not based on color (may be an advantage in some cases)
to work with date values instead of numbers replace IsNumeric(cel) with IsDate(cel)
I used the following conditional formatting rules (in 4 columns):
=A2=MAX(A$2:A$7)
=B2=MAX(B$2:B$7)
=C2=MAX(C$2:C$7)
=D2=MAX(D$2:D$7)
CF manager:
Result:
Note: #Tim's comments helped identify other key requirements such as UDF
.
To determine total rows (initial answer):
Option Explicit
Sub countRowsWithConditionalColor()
Dim totalRows As Long, rng As Range, lColor As Long, cel As Range, lRow As Long
lRow = ActiveSheet.UsedRange.Rows.Count
Set rng = ActiveSheet.Range("A1:A" & lRow)
lColor = RGB(255, 0, 0) 'change color accordingly
Application.ScreenUpdating = False
With rng
.AutoFilter Field:=1, Criteria1:=lColor, Operator:=xlFilterCellColor
For Each cel In rng
If cel.RowHeight > 0 Then totalRows = totalRows + 1
If cel.Row > lRow Then Exit For
Next
.AutoFilter
End With
Application.ScreenUpdating = True
MsgBox "TotalRows: " & totalRows
End Sub
turns off ScreenUpdating, so this process is not visible to the user (and faster)
applies an AoutoFileter on column 1, color to filter by, and "Operator:=xlFilterCellColor"
loops through all cells in the column
if current cell has a height > 0 (is visible) increments the counter (totalRows)
turns ScreenUpdating back on
shows the total rows
Notes:
My test color (vbRed) is generated by a conditional formatting rule
Tim's suggestion rColor.DisplayFormat.Interior.ColorIndex might be better suited for your code if it works
Paul's answer is pretty good and easy to understand. Just make sure you select right column by changing value after "Field:=". 1 stands for col. A, 2 for B etc. Also make sure you have autofilter turned on before running the macro. And also replace .AutoFilter bit with ActiveSheet.ShowAllData after End With. This way it won't disable your autofilter.
In a previous post user: LocEngineer managed to help me to write a finding function that would find the least frequent values in a column of a particular category.
The VBA code works well for the most part with some particular issues, and the previous question had been answered with a sufficiently good answer already, so I thought this required a new post.
LocEngineer: "Holy smoking moly, Batman! If THAT truly is your sheet.... I'd say: forget "UsedRange". That won't work well enough with THAT spread... I've edited the above code using more hardcoded values. Please adapt the values according to your needs and try that. Woah what a mess."
Here is the code:
Sub frequenz()
Dim col As Range, cel As Range
Dim letter As String
Dim lookFor As String
Dim frequency As Long, totalRows As Long
Dim relFrequency As Double
Dim RAN As Range
RAN = ActiveSheet.Range("A6:FS126")
totalRows = 120
For Each col In RAN.Columns
'***get column letter***
letter = Split(ActiveSheet.Cells(1, col.Column).Address, "$")(1)
'*******
For Each cel In col.Cells
lookFor = cel.Text
frequency = Application.WorksheetFunction.CountIf(Range(letter & "2:" & letter & totalRows), lookFor)
relFrequency = frequency / totalRows
If relFrequency <= 0.001 Then
cel.Interior.Color = ColorConstants.vbYellow
End If
Next cel
Next col
End Sub
The Code is formatted like this: (Notice the merged cells that head each column for titles. The titles go down to row 5 and data starts on row 5) (Also Notice that the rows are very much filled with empty columns, sometimes more so than data.)
Finally, one important change I cant figure out is how to get it to ignore blank cells.
Please advise. Thank you.
If the 2 adjustments to be made are to 1. exclude headers, and 2. blank cells
Exclude the headers in way a bit more dynamic; this excludes the top 6 rows:
With ActiveSheet.UsedRange
Set ran = .Offset(6, 0).Resize(.Rows.Count - 6, .Columns.Count)
End With
In the inner For loop, after this line For Each cel In col.Cells you need an IF:
For Each cel In col.Cells
If Len(cel.Value2) > 0 Then...
Here is the modified version (untested):
Option Explicit
Sub frequenz()
Const MIN_ROW As Long = 6
Const MAX_ROW As Long = 120
Dim col As Range
Dim cel As Range
Dim rng As Range
Dim letter As String
Dim lookFor As String
Dim frequency As Long
With ActiveSheet.UsedRange
Set rng = .Offset(MIN_ROW, 0).Resize(MAX_ROW, GetMaxCell.Column)
End With
For Each col In rng.Columns
letter = Split(ActiveSheet.Cells(1, col.Column).Address, "$")(1)
For Each cel In col
lookFor = cel.Value2
If Len(lookFor) > 0 Then 'process non empty values
frequency = WorksheetFunction.CountIf( _
Range(letter & "2:" & letter & MAX_ROW), lookFor)
If frequency / MAX_ROW <= 0.001 Then
cel.Interior.Color = ColorConstants.vbYellow
End If
End If
Next cel
Next col
End Sub
.
Updated to use a new function when determining the last row and column containing values:
Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
'It returns the last cell of range with data, or A1 if Worksheet is empty
Const NONEMPTY As String = "*"
Dim lRow As Range, lCol As Range
If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
If WorksheetFunction.CountA(rng) = 0 Then
Set GetMaxCell = rng.Parent.Cells(1, 1)
Else
With rng
Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows)
Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
After:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns)
Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
End With
End If
End Function