I have been trying to write a search function in VBA to search for a specific word - or rather the lack thereof - in cells. I need to go through a range of cells. There are two columns, if neither one of the cells a row contains the word, the row should be flagged - e.g. change colors. I am able to search one column, but when I try to search across two columns Excel bombs out. The columns are contained in a Pivot Table.
I have attached my code below. Any recommendations?
Private Sub AnalyseCTCN_Click()
Dim CT2CFN1 As Range 'CT2CFN1 is column 1
Dim CT2CFN2 As Range 'CT2CFN2 is column 2
Dim CT2CFN As Range
Set CT2CFN1 = Intersect(PivotTables("PivotTableCTCN").PivotFields("CUST_TYPE").PivotItems("2").DataRange.EntireRow, _
PivotTables("PivotTableCTCN").PivotFields("CUST_FULL_NAME_1").DataRange)
Set CT2CFN2 = Intersect(PivotTables("PivotTableCTCN").PivotFields("CUST_TYPE").PivotItems("2").DataRange.EntireRow, _
PivotTables("PivotTableCTCN").PivotFields("CUST_FULL_NAME_2").DataRange)
Set CT2CFN = Union(CT2CFN1, CT2CFN2)
Dim d As Range
Dim c As Range
For Each d In CT2CFN1
For Each c In CT2CFN2
If InStr(1, d, "T/A", 1) = 0 And InStr(1, c, "T/A", 1) = 0 Then
d.Interior.Color = RGB(255, 0, 0)
End If
Next c
Next d
End Sub
Related
I'm wondering if its possible to create a VBA that map a random "numerical codes" from an excel Spreadsheet 2 (let's say column A) to a column B (Spreadsheet 1).
Some of the values on the spreadsheet 2 are repeated, I would like to build a unique correspondence (no repeated values from column A / Spreadsheet 2 to my column B / Spreadsheet 1)
Spreadsheet1:
Spreadsheet2
Desired output, column filled from Spreadsheet2 (Unique)values :
Is this possible?? feasible??
The following VBA code uses for loops to iterate through the list of values in Spreadsheet2 and only copy each value to Spreadsheet1 if the value has not occurred already in the list.
Option Explicit
Sub ListUniqueCodes()
Dim code As Long
Dim codes As Range
Dim i As Integer
Dim j As Integer
Dim last_row As Integer
Dim output_cell As Range
Dim unique_codes As New Collection 'You could also use a Scripting.Dictionary here as suggested by JvdV
'See https://stackoverflow.com/questions/18799590/avoid-duplicate-values-in-collection
'Store the length of the list of codes that is in Spreadsheet2:
last_row = Workbooks("Spreadsheet2.xlsx").Sheets("Sheet1").Range("A1").End(xlDown).Row
'Store the list of codes that is in Spreadsheet2:
Set codes = Workbooks("Spreadsheet2.xlsx").Sheets("Sheet1").Range("A1:A" & last_row)
'For each code...
For i = 1 To codes.Rows.Count
code = codes.Cells(i).Value2
'...if it does not equal zero...
If code <> 0 Then
'...and if it is not already in the collection unique_codes...
For j = 1 To unique_codes.Count
If unique_codes(j) = code Then Exit For
Next j
'...then add it to the collection unique_codes:
If j = (unique_codes.Count + 1) Then
unique_codes.Add code
End If
End If
Next i
Set output_cell = Workbooks("Spreadsheet1.xlsm").Sheets("Sheet1").Range("B2")
'Write out the unique codes in Spreadsheet1:
For i = 1 To unique_codes.Count
output_cell.Offset(i - 1, 0).Value2 = unique_codes(i)
Next i
End Sub
I want to perform a simple calculation on another cell based off a key word in the string from a different cell. For example Column H might have a description along the lines of "Purchase of 50,000 shares." I want to multiple Column B by -1 if the word Purchase appears. Is it possible to build a condition off of a key word in a string?
You can do it in formula or VBA.
In formula, say B1 had content X before, you change to formula
=(X) * IF(ISNUMBER(SEARCH("Purchase", H1)), -1, 1)
In VBA, try this
Sub NegateB_IfPurchaseH()
Dim celB As Range
Dim celH As Range
Dim celPtr As Range
' you can change 1:10 to any other range
Set celB = Range("B1:B10")
Set celH = celB.Cells(1, 7)
For Each celPtr In celB
If InStr(1, celPtr.Cells(1, 7).Value, "purchase", vbTextCompare) > 0 Then
celPtr.Formula = "=-" & Mid(celPtr.Formula, 2)
End If
Next
End Sub
I want to match the employee name on sheet one against employee names in sheet two, then run a count of all yellow-colored (filled) cells in a particular column.
I have a VBA module that will run the count of highlighted cells without doing a name match and it works perfectly. Now I need to add in an additional metric of running a count of all highlighted cells for each employee.
Data Info:
Sheet One B2:B50 - list of employee last names.
Sheet Two D2:D1845 - column with employee last names. Note: This is a worksheet with 1845 line items of client data records and therefore the employee name could be listed numerous times in said column.
Sheet Two E2:E1845 - column with yellow-colored cells. Not all cells in the column are colored yellow. Which is why I need a count of how many are colored for each employee.
Count by color VBA that works:
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
Based on what you explained to me you want in the comments here's a one-liner to do what you want:
Public Sub NameColorCount(NameToSearch As String, TargetCell As Range, _
SearchRange As Range, RangeToCountColor As Range, ColorRange As Range)
If Not SearchRange.Find(NameToSearch) Is Nothing Then
TargetCell.Value = CountByColor(RangeToCountColor, ColorRange)
End If
End Sub
If you want to do this in a cell you can use CountByColor as a UDF and use the following formula:
=IF(COUNTIF(D:D, B1)>0,CountByColor(E:E, B1),"")
Assuming your ColorRange is the 'B' cell, modify otherwise
I'm not really sure if this is what you want to achieve I can't post images yet.
This Sub insert a counter in range Sheet1 C2:C50 for every employee who is in Sheet2 D2:D1845 and the cell next to is yellow colored.
Sub Find_Matches()
Dim CompareRange As Variant, x As Variant, y As Variant, CountA As Integer
Set EmployeeRange = Worksheets("Sheet1").Range("B2:B50")
Set CompareRange = Worksheets("Sheet2").Range("D2:D1845")
For Each x In EmployeeRange
For Each y In CompareRange
If x = y And y.Offset(0, 1).Interior.ColorIndex = 6 Then CountA = CountA + 1
Next y
x.Offset(0, 1).Value = CountA
CountA = 0
Next x
End Sub
I'm a total newbie in VBA, just started this morning when confronted with a spreadsheet with ~30K rows.
I have two worksheets:
named "tohere", contains ordinal numbers in column C.
named "fromhere", contains numbers in column C and values in column B. It's basically the same ordinal numbers, but some are missing - that's why I started to write a macro in he first place.
I want Excel to check if the number in "tohere", Cell C1 exists in any cell in "fromhere", column C, and if it does, copy the value from the corresponding row in "fromhere", column B into "tohere", Cell B1; then do it again for C2 etc. If there's no such number in sheet "fromhere", just do nothing about this row.
I tried this code:
Dim i As Long
Dim tohere As Worksheet
Dim fromhere As Worksheet
Set tohere = ThisWorkbook.Worksheets("tohere")
Set fromhere = ThisWorkbook.Worksheets("fromhere")
For i = 1 To 100
If fromhere.Range("C" & i).Value <> tohere.Range("C" & i).Value Then
Else: fromhere.Cells(i, "B").Copy tohere.Cells(i, "B")
End If
Next i
It does what I want for the first cells that are equal (4 in my case) and then just stops without looking further.
I tried using Cells(i, "C") instead, same thing. Using i = i + 1 after Then doesn't help.
I feel that the problem is in my cells addressing, but I don't understand how to fix it.
This is how my sample "fromhere" list looks like (you can notice some numbers are missing from the C column):
This is the sample of what I get with the "tohere" list:
It gets to the point where there's no "5" in "fromhere" and stops at this point.
P.S.: i = 1 To 100 is just to test it.
This should do your job. Run this and let me know.
Sub test()
Dim tohere As Worksheet
Dim fromhere As Worksheet
Dim rngTohere As Range
Dim rngfromHere As Range
Dim rngCelTohere As Range
Dim rngCelfromhere As Range
'Set Workbook
Set tohere = ThisWorkbook.Worksheets("tohere")
Set fromhere = ThisWorkbook.Worksheets("fromhere")
'Set Column
Set rngTohere = tohere.Columns("C")
Set rngfromHere = fromhere.Columns("C")
'Loop through each cell in Column C
For Each rngCelTohere In rngTohere.Cells
If Trim(rngCelTohere) <> "" Then
For Each rngCelfromhere In rngfromHere.Cells
If UCase(Trim(rngCelTohere)) = UCase(Trim(rngCelfromhere)) Then
rngCelTohere.Offset(, -1) = rngCelfromhere.Offset(, -1)
Exit For
End If
Next rngCelfromhere
End If
Next rngCelTohere
Set tohere = Nothing
Set fromhere = Nothing
Set rngTohere = Nothing
Set rngfromHere = Nothing
Set rngCelTohere = Nothing
Set rngCelfromhere = Nothing
End Sub
I'm trying to count the number of unique cells in column C that don't have a "#" or "-" inside.
I have a column of cells that contain names. Some of these names are repeated, and some have characters such as "-" and/or "#" inside - I'm trying to exclude these cells from being counted.
I have 2 formulas that each does half of what I need, but I need to combine the 2 formulas to get the right answer:
This formula counts the number of unique cells (and takes care of blanks): =SUM(IF(COUNTIF(C4:C3689,C4:C3689)=0, "", 1/COUNTIF(C4:C3689,C4:C3689)))
This formula counts the number of cells that don't have a "#" or "-": =SUMPRODUCT(N(LEN(SUBSTITUTE(SUBSTITUTE(C4:C3689,"-",""),"#",""))=LEN(C4:C3689)))
Do you know how to combine the 2 formulas? If you know how to combine the two formulas in a different way (custom function or VBA) that would be great too.
Thanks.
This formula will count the number of different entries in the specified range, excluding any that contain # or -
=SUMPRODUCT((ISERR(SEARCH("#",C4:C3689))*ISERR(SEARCH("-",C4:C3689))*(C4:C3689<>""))/COUNTIF(C4:C3689,C4:C3689&""))
Use a function like this:
=GetUniqueCount("C4:C3689")
Add the function code:
Function GetUniqueCount(rng As Range) As Variant
'Dim rng as Range
'Set rng = Range("C4:C3869") 'Modify as needed
Dim r as Range
Dim uniqueCount as Long
Dim dict as Object
Set dict = CreateObject("Scripting.Dictionary")
For each r in rng.Cells
If Not dict.Exists(r.Value) Then
If Instr(1, r.Value, "#") = 0 Then
If Instr(1, r.Value, "-") = 0 Then
dict(r) = ""
uniqueCount = uniqueCount + 1
End If
End If
End If
Next
GetUniqueCount = uniqueCount
Set dict = Nothing
End Function