Excel VBA code to compare text strings in two columns and highlight certain text strings not the whole cell? - excel

I need to do a vba code to compare texts in two columns and highlight matched texts in the second column. I started on the code and below is what I got so far. It works fine on the first row, how to modify the code to apply this for the entire table not just the first row. I'm new to VBA and any help would be great.
Sub Test1()
Dim strString$, x&
Dim rngCell As Range
strString = Range("G2").Value
Application.ScreenUpdating = False
For Each rngCell In Range("S2", Range("S" & Rows.Count).End(xlUp))
With rngCell
.Font.ColorIndex = 1
For x = 1 To Len(.Text) - Len(strString) Step 1
If Mid(.Text, x, Len(strString)) = strString Then .Characters(x, Len(strString)).Font.ColorIndex = 5
Next x
End With
Next rngCell
Application.ScreenUpdating = True
End Sub

If your code works correctly on the first row (I haven't tested it, so will just trust that you are correct), then the following is, I think, what you want to change:
Sub Test1()
Dim strString$, x&
Dim rngCell As Range
Application.ScreenUpdating = False
For Each rngCell In Range("S2", Range("S" & Rows.Count).End(xlUp))
With rngCell
.Font.ColorIndex = 1
strString = Cells(rngCell.Row, "G").Value
For x = 1 To Len(.Text) - Len(strString) Step 1
If Mid(.Text, x, Len(strString)) = strString Then .Characters(x, Len(strString)).Font.ColorIndex = 5
Next x
End With
Next rngCell
Application.ScreenUpdating = True
End Sub
i.e. move the calculation of strString inside the loop and base it on the value in column G of the row being processed.

I just gave someone this answer to a very similar question...
Sub ColorMatchingString()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim strTest As Collection: Set strTest = New Collection
Dim udRange As Range: Set udRange = ws.Range("AC2:AC311") 'Define Search Ranges
Dim myCell, myMatch, myString, i
Dim temp() As String, tempLength As Integer, stringLength As Integer
Dim startLength as Integer
For Each myMatch In udRange 'Build the collection with Search Range Values
strTest.Add myMatch.Value
Next myMatch
For Each myCell In ws.Range("A2:AB1125") 'Loop through each cell in range
temp() = Split(myCell.Text, ", ") 'define our temp array as "," delimited
startLength = 0
stringLength = 0
For i = 0 To UBound(temp) 'Loop through each item in temp array
tempLength = Len(temp(i))
stringLength = stringLength + tempLength + 2
For Each myString In strTest
'Below compares the temp array value to the collection value. If matched, color red.
If StrComp(temp(i), myString, vbTextCompare) = 0 Then
startLength = stringLength - tempLength - 1
myCell.Characters(startLength, tempLength).Font.Color = vbRed
End If
Next myString
Next i
Erase temp 'Always clear your array when it's defined in a loop
Next myCell
End Sub

Related

VBA Code: How would you split a string in a cell into sections and displaying those section in a new column using offset function

I am trying to find a way that takes a player's name from cell A2 which in that cell reads (Name, Position, School) and splitting their name, position, and school in a different columns using the offset command. The problem I am having is when I split the cell it also splits the name and I need the name to stay together. For example, Jaylen Coleman RB Duke It splits it into "Jaylen" "Coleman" "RB" "Duke" when I need it to split into "Jaylen Coleman" "RB" "Duke" and then offset those splits 12 columns over.
Sub ParseName()
Dim ACC As Worksheet
Dim lastRow As Long
Dim PlayerPosition As Range
Dim dataList As Range
Dim arrData As Variant
Dim i As Variant
Set ACC = ThisWorkbook.Worksheets("ACC Statistics")
lastRow = ACC.Cells(ACC.Rows.count, "A").End(xlUp).Row
Set dataList = ACC.Range("A1").Resize(lastRow, 1)
For Each PlayerPosition In dataList
arrData = Split(PlayerPosition.Value)
For i = LBound(arrData) To UBound(arrData)
ACC.Cells(PlayerPosition.Row, i + 12).Value = arrData(i)
Next
Next
End Sub
Try this I've added random positions RR and ZZ, just use | as an "or"
Sub rege()
With CreateObject("vbscript.regexp")
.Pattern = "(.+) (RB|RR|ZZ) (.+)"
With .Execute("Jaylen X. Coleman RB Duke")
If .Count > 0 Then
If .Item(0).Submatches.Count = 3 Then
MsgBox .Item(0).Submatches(0) & vblf & _
.Item(0).Submatches(1) & vblf & _
.Item(0).Submatches(2)
End If
End If
End With
End With
End Sub
Your code should look like this (If you are not a mac user :)
Sub ParseName()
Dim ACC As Worksheet
Dim lastRow As Long
Dim PlayerPosition As Range
Dim dataList As Range
Dim arrData As Variant
Dim i As Variant
Set ACC = ThisWorkbook.Worksheets("ACC Statistics")
lastRow = ACC.Cells(ACC.Rows.Count, "A").End(xlUp).Row
Set dataList = ACC.Range("A1").Resize(lastRow, 1)
With CreateObject("vbscript.regexp")
.Pattern = "(.*) (RB|QB|WR) (.*)"
For Each PlayerPosition In dataList
With .Execute(" " & PlayerPosition.Value & " ")
If .Count > 0 Then
If .Item(0).Submatches.Count > 0 Then
For i = 0 To .Item(0).Submatches.Count - 1
ACC.Cells(PlayerPosition.Row, i + 12).Value = Trim(.Item(0).Submatches(i))
Next i
End If
End If
End With
Next
End With
End Sub
Add all your positions in Pattern string in RB|QB|WR part just use | as a separator

Two Dependent Combo Boxes

**Edit:** Managed to find the solution to it thanks to fellow user #Tin Bum
I'm trying to make 2 Combo Box where the the first one (Cmb1) will show only unique values from Column 1 and then (Cmb2) will show a list of values from Column 2 that are related to Column 1.
Populating the Cmb1 has been successful however the problem lies with populating Cmb2.
Column 1 Column 2
1 a
1 b
1 c
2 d
2 e
The problem lies with populating Cmb2
Private Sub UserForm_Activate()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
With wslk
t1 = .Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).row
On Error Resume Next
For y = 2 To t1
Set c = .Cells(y, 2)
Set t1rng = .Range(.Cells(2, 2), .Cells(y, 2))
x = Application.WorksheetFunction.CountIf(t1rng, c)
If x = 1 Then Cmb1.AddItem c
Next y
On Error GoTo 0
End With
End Sub
Private Sub Cmb1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
Private Sub Cmb1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
Cmb2.ListIndex = -1
If Cmb1.ListIndex > -1 Then
'Currently I am stuck over here
Cmb2.List =
**Solution:**
Dim i As Integer
Cmb2.Clear
For i = 2 To wslk.Range("B" & Application.Rows.Count).End(xlUp).row
If wslk.Range("B" & i).Value = Cmb1.Value Then
Cmb2.AddItem wslk.Range("C" & i)
End If
End If
End Sub
This the bones of a solution for the Exit Event Code.
It should be Ok for hundreds of rows but may be slow for thousands of rows, also you still have to workout the 2 ranges - I've arbitrarily assigned them to fixed ranges.
On the plus side it should be simple to follow
Dim Rng1 As Range, Rng2 As Range
Dim xCel As Range, List2 As String
Rng1 = Range("A10:A20") ' whatever Range covers your Col1 Data
Rng2 = Range("B10:B20") ' whatever Range covers your Col2 Data
List2 = ""
For Each xCel In Rng2.Cells
If xCel.Offset(0, -1).Value = Combobox1.Value Then
' Add this Value to a String using VbCrLf as a Separator
List2 = IIf(List2 = "", "", List2 & vbCrLf) & CStr(xCel.Value)
End If
Next xCel
' Split the String into an Array of Values for ComboBox2
ComboBox2.List = Split(List2, vbCrLf)
It also relies on NOT HAVING CHR(13) & CHR(10) (VbCrLF) in your data
You could use a Dictionary to get your unique values and also populate this on your Initialize Sub. Making this a Public variable in the scope of the Userform will allow you to then use it later on the Change event as well to get your list values
Option Explicit
Private Uniques As Object
Private Sub UserForm_Initialize()
Dim c As Range, InputRng As Range
Dim tmp As Variant
Dim k As String
Set Uniques = CreateObject("Scripting.Dictionary")
With Worksheets("w1")
Set InputRng = .Range(.Cells(2, 2), .Cells(.Cells(.Rows.Count, 2).End(xlUp).Row, 2))
For Each c In InputRng
k = c.Value2
If Uniques.exists(k) Then
tmp = Uniques(k)
ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
tmp(UBound(tmp)) = c.Offset(0, 1).Value2
Uniques(k) = tmp
Else
ReDim tmp(0)
tmp(0) = c.Offset(0, 1).Value2
Uniques.Add Key:=k, Item:=tmp
End If
Next c
Cmb1.List = Uniques.keys
End With
End Sub
Private Sub Cmb1_Change()
Cmb2.ListIndex = -1
If Cmb1.ListIndex > -1 Then
Cmb2.List = Uniques(Cmb1.Value)
End If
End Sub
Private Sub Cmb1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("w1")
Dim i As Integer
Cmb2.Clear
For i = 2 To wslk.Range("B" & Application.Rows.Count).End(xlUp).row
If wslk.Range("B" & i).Value = Cmb1.Value Then
Cmb2.AddItem wslk.Range("C" & i)
End If

Conditionally hiding columns

I am trying to hide columns (Z,AA,AB,AC) if one of dependent cells are blank. i.e. if Range1 is blank entire column Z is hidden, Range2 is blank then entire column AA is hidden etc.
I know I could implement simple If Else/ .EntireColumn.Hidden statment but I was thinking to use code like below to make it neater. Any suggestions how to make it work ?
Sub(test)
Dim cell As Variant
Dim i As Integer
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("ReturnedHoldMail")
Set MyArray(1) = Sheets("test1").Range("Range1")
Set MyArray(2) = Sheets("test1").Range("Range2")
Set MyArray(3) = Sheets("test1").Range("Range3")
Set MyArray(4) = Sheets("test1").Range("range4")
For i = LBound(MyArray) To UBound(MyArray)
On Error Resume Next
For Each cell In MyArray(i)
If Len(cell.Value) < 1 Then
cell.EntireColumn.Hidden = True
Else
cell.EntireColumn.Hidden = False
End If
Next
Next
End With
End Sub
If you want the ranges that are hidden to be independent of the ranges being tested for emptiness, try the following:
Sub test()
Dim cell As Range
Dim i As Integer
Dim MyArray(1 To 4) As Range
Dim HideArray(1 To 4) As Range
Dim will_hide As Boolean
Set MyArray(1) = Sheets("test1").Range("Range1")
Set MyArray(2) = Sheets("test1").Range("Range2")
Set MyArray(3) = Sheets("test1").Range("Range3")
Set MyArray(4) = Sheets("test1").Range("Range4")
Set HideArray(1) = Sheets("test1").Range("Range5") ' or eg. Sheets("test2").Range("Z:Z")
Set HideArray(2) = Sheets("test1").Range("Range6")
Set HideArray(3) = Sheets("test1").Range("Range7")
Set HideArray(4) = Sheets("test1").Range("Range8")
For i = LBound(MyArray) To UBound(MyArray)
will_hide = True
For Each cell In MyArray(i)
If Len(cell.Value) > 0 Then
will_hide = False
End If
Next
HideArray(i).EntireColumn.Hidden = will_hide
Next
End Sub

Output Range same as input range

I have some history working with VBA, but can't seem to find the solution to this problem. I found an iteration process to select a cell, do a process, and then select the next cell and do the process again, until NULL. I am having a problem outputting each of the processes solutions into the next column. Here is what I have:
Sub Name ()
Dim X As Integer
Dim MyString as String
Application.ScreenUpdating = False
NumRows = Range("D2", Range("D2").End(xlDown)).Rows.Count
Range("D2").Select
For X = 1 To NumRows
MyString = ActiveCell.Value
MyString = Right(MyString, Len(MyString)-6)
Range("I2 to I#").Value = MyString
ActiveCell.Offset(1,0).Select
Next X
End Sub
Range("I2 to I#").Value = MyString is the line that I need help with. I need it to increment to I3, I4, I5, etc. until it reaches NumRows count.
When working with Cells the best way to loop through them is For Each Cell in Range so taking this and as comments told you to avoid selecting, this should help you:
Option Explicit
Sub Name()
Dim C As Range, MyRange As Range
Dim LastRow As Long
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("MySheet") 'Change MySheet for your working sheet name
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row on column D
Set MyRange = .Range("D2:D" & LastRow) 'declare your working range
For Each C In MyRange
If Not C = vbNullString Then .Cells(C.Row, "I") = Right(C, Len(C) - 6)
Next C
End With
Application.ScreenUpdating = True
End Sub
Another solution is Do Until. You could use this method if you dont have empty cells in the middle of your data.
Option Explicit
Sub Test()
Dim StartingPoint As Long
StartingPoint = 2 'Set the line to begin
With ThisWorkbook.Worksheets("Sheet1") 'Set the worksheet
Do Until .Cells(StartingPoint, "D").Value = "" 'Repeat the process until you find empty cell
.Cells(StartingPoint, "I").Value = Right(.Cells(StartingPoint, "D").Value, Len(.Cells(StartingPoint, "D").Value) - 6)
StartingPoint = StartingPoint + 1
Loop
End With
End Sub

Finding and leaving only duplicates in spreadsheet

In Excel, I created a macro to find and leave only duplicated values across multiple columns within the current selection--removing any cells that were only found once. Well, at least that's what I thought I created anyway, but it doesn't seem to work. Here's what I've got:
Sub FindDupsRemoveUniq()
Dim c As Range
Dim counted() As String
For Each c In selection.Cells
Dim already_found As Boolean
already_found = Contains(counted, c.Text)
If Not (already_found) And WorksheetFunction.CountIf(selection, c) <= 1 Then
c.Delete Shift:=xlUp
ElseIf ("" <> c.Text) And Not (already_found) Then
If Len(Join(counted)) = 0 Then
ReDim counted(1)
Else
ReDim Preserve counted(UBound(counted) + 1)
End If
counted(UBound(counted) - 1) = c.Text
End If
Next c
End Sub
Private Function Contains(ByRef arr() As String, cell As String) As Boolean
Dim i As Integer
Contains = False
If Len(Join(arr)) = 0 Then
Exit Function
End If
For i = LBound(arr) To UBound(arr)
If cell = arr(i) Then
Contains = True
Exit Function
End If
Next
End Function
I had to do this because I had ~180k items across multiple columns, and I had to find anything that was duplicated, and under which column those duplicates are showing in. However, when it completes, it seems that most of the singular instances are still there. I can't figure out why this isn't working.
EDIT: This is what my code ended up looking like based on #brettdj's solution below:
Sub FindDupsRemoveUniq()
Dim lRow As Long
Dim lCol As Long
Dim total_cells As Long
Dim counter As Long
Dim progress_str As String
Dim sel
sel = selection.Value2
total_cells = WorksheetFunction.Count(selection)
counter = 0
progress_str = "Progress: "
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.StatusBar = progress_str & "0 of " & total_cells & " : 0% done"
For lRow = 1 To UBound(sel, 1)
For lCol = 1 To UBound(sel, 2)
counter = counter + 1
Application.StatusBar = progress_str & counter & " of " & total_cells & " : " & Format(counter / total_cells, "0%")
If WorksheetFunction.CountIf(selection, sel(lRow, lCol)) < 2 Then
sel(lRow, lCol) = vbNullString
End If
Next lCol
Next lRow
selection = sel
Application.StatusBar = "Deleting blanks..."
selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Application.StatusBar = "Done"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I tried to speed things up with a few optimizations, though I'm not sure how much they helped. Also, the status bar updates ended up being rather pointless too since Excel got so bogged down. It seemed to give up updating after ~300 iterations. Nonetheless, it did work.
I would suggest using an array, same approach otherwise as simoco
This approach removes the cell contents but doesn't shift the cells up as I wasn't clear that you wanted this
Sub Kill_Unique()
Dim X
Dim lngRow As Long
Dim lngCol As Long
X = Selection.Value2
For lngRow = 1 To UBound(X, 1)
For lngCol = 1 To UBound(X, 2)
If Application.CountIf(Selection, X(lngRow, lngCol)) < 2 Then X(lngRow, lngCol) = vbNullString
Next lngCol
Next lngRow
Selection.Value2 = X
End Sub
If you want delete all cells with unique values from selection, try this one:
Sub test()
Dim rngToDelete As Range, c As Range
For Each c In Selection
If WorksheetFunction.CountIf(Selection, c) = 1 Then
If rngToDelete Is Nothing Then
Set rngToDelete = c
Else
Set rngToDelete = Union(rngToDelete, c)
End If
End If
Next
If Not rngToDelete Is Nothing Then rngToDelete.Delete Shift:=xlUp
End Sub

Resources