How to copy the column A to M from a row in sheet1 to sheet2 if it doesn't already exist - excel

I would like to select some rows by putting an X in the column L, then copy selected row (Only column A to M) to the next free row in sheet2.
Free row mean there is nothing in the column A to M since there is content in the next column already filled.
The copy shouldn't erase the content already existing after column M.
The row can't be added if it's already in the sheet2 and to test this, I have an unique ID for the row in column M.
Some of the column of the row that should be copied are sometimes empty.
Part of what I tried :
Sub GAtoList()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim L As Long
A = Worksheets("knxexport").Range("d" & Worksheets("knxexport").Rows.Count)
B = Worksheets("Sheet2").UsedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Sheet2").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("knxexport").Range("L1:L" & A)
Application.ScreenUpdating = False
For L = 1 To xRg.Count
If CStr(xRg(L).Value) = "X" Then
xRg(L).EntireRow.Copy Destination:=Worksheets("Sheet2").Range("A" & B + 1)
B = B + 1
Cells(L, B).EntireRow.Interior.ColorIndex = 4
End If
Next
'Erase the X that select the row I want to copy
Worksheets("knxexport").Columns(12).ClearContents
Worksheets("Sheet2").Columns(12).ClearContents
Application.ScreenUpdating = True
End Sub
Column D is never empty so I use it to check the end of the source sheet
knxexport sheet where I take data
sheet2 where I want to copy them

Please, test the next code:
Sub GAtoList()
Dim sh As Worksheet, shDest As Worksheet, lastRL As Long, LastRM As Long
Dim strSearch As String, rngM As Range, arrCopy, cellF As Range, rngL As Range, cellFAddress As String, i As Long, mtch
strSearch = "X"
Set sh = 'Worksheets("knxexport") 'the sheet to copy from
Set shDest = 'Worksheets("Sheet2") 'the sheet to copy to
shDest.Range("M:M").NumberFormat = "#" 'format the M:M column as text
lastRL = sh.Range("L" & sh.rows.count).End(xlUp).row
Set rngL = sh.Range("L2:L" & lastRL) 'the range to search for "X"
Set cellF = rngL.Find(what:=strSearch, After:=sh.Range("L2"), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
If Not cellF Is Nothing Then 'If at least an "X" string has been found:
cellFAddress = cellF.Address 'memorize its (first) address
Do
LastRM = shDest.Range("M" & shDest.rows.count).End(xlUp).row 'last row in M:M
If LastRM > 1 Then 'if there already are IDs:
Set rngM = shDest.Range("M2:M" & LastRM)
mtch = Application.match(sh.cells(cellF.row, "M").Value, rngM, 0)
If IsError(mtch) Then 'no ID found
shDest.Range("A" & LastRM + 1 & ":" & "M" & LastRM + 1).Value = _
sh.Range(sh.Range("A" & cellF.row), sh.Range("M" & cellF.row)).Value
Else
Debug.Print sh.cells(cellF.row, "M").Value & " already existing..." 'warn in case of ID existence...
End If
Else
'copy in the second row
shDest.Range("A2:M2").Value = _
sh.Range(sh.Range("A" & cellF.row), sh.Range("M" & cellF.row)).Value
End If
Set cellF = rngL.FindNext(cellF)
Loop While cellF.Address <> cellFAddress 'exit to avoid restarting loop from the memorized address
Else
MsgBox strSearch & " could not be found in ""L:"" column...": Exit Sub
End If
End Sub

Related

Loop through column matching data in workbook and return a value

I have been trying to adapt the following code to
Loop through column A of Sheet 1 and for each value in column A search the whole workbook for it's matching value (which will be found in another sheet also in column A). When a match is found, return the value found in the same row but from column F.
Sub Return_Results_Entire_Workbook()
searchValueSheet = "Sheet2"
searchValue = Sheets(searchValueSheet).Range("A1").Value
returnValueOffset = 5
outputValueSheet = "Sheet2"
outputValueCol = 2
outputValueRow = 1
Sheets(outputValueSheet).Range(Cells(outputValueRow, outputValueCol), Cells(Rows.Count, outputValueCol)).Clear
wsCount = ActiveWorkbook.Worksheets.Count
For I = 1 To wsCount
If I <> Sheets(searchValueSheet).Index And I <> Sheets(outputValueSheet).Index Then
'Perform the search, which is a two-step process below
Set Rng = Worksheets(I).Cells.Find(What:=searchValue, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
rangeLoopAddress = Rng.Address
Do
Set Rng = Sheets(I).Cells.FindNext(Rng)
Sheets(outputValueSheet).Cells(Cells(Rows.Count, outputValueCol).End(xlUp).Row + 1, outputValueCol).Value = Sheets(I).Range(Rng.Address).Offset(0, returnValueOffset).Value
Loop While Not Rng Is Nothing And Rng.Address <> rangeLoopAddress
End If
End If
Next I
End Sub
The code above works but only for the first row of data on Sheet1.
Any help would be greatly appreciated!
You can create an array of arrays where each index of main array would be the dataset A:F from each worksheet:
Sub test()
Dim WK As Worksheet
Dim LR As Long
Dim i As Long
Dim j As Long
Dim MasterArray() As Variant
Dim WkArray As Variant
'create master aray
ReDim MasterArray(1 To ThisWorkbook.Worksheets.Count - 1) 'As many indexes as worksheets -1 (because master sheet does not count)
i = 1
For Each WK In ThisWorkbook.Worksheets
If WK.Name <> "Hoja1" Then 'exclude master sheet witch search values
LR = WK.Range("A" & WK.Rows.Count).End(xlUp).Row 'last non-blank row
WkArray = WK.Range("A1:F" & LR).Value 'take all values in A:F to singlearray
MasterArray(i) = WkArray
Erase WkArray
i = i + 1
End If
Next WK
'now in Master array you have in each index all the values
' as example, if you call MasterArray(1)(1, 1) it will return cell value A1 from first worksheet
Set WK = ThisWorkbook.Worksheets("Hoja1") 'master sheet witch search values
With Application.WorksheetFunction
LR = WK.Range("A" & WK.Rows.Count).End(xlUp).Row 'last non-blank row
For i = 1 To LR Step 1 'for each row in master sheet until last non blank
For j = 1 To UBound(MasterArray) Step 1 'for each dataset in masterarray
WkArray = Application.Transpose(Application.Index(MasterArray(j), , 1)) 'first column of dataset (A column)
If IsError(Application.Match(WK.Range("A" & i).Value, WkArray, 0)) = False Then 'if value exists get F
WK.Range("B" & i).Value = .VLookup(WK.Range("A" & i).Value, MasterArray(j), 6, 0)
Erase WkArray
Exit For
End If
Erase WkArray
Next j
Next i
End With
Erase MasterArray
Set WK = Nothing
End Sub
The code first creates the main array named MasterArray. Then it loops trough each value on column A from Master Sheet (named Hoja1 in my example) and checks if the value exists in each subarray. If it does then returns columns F from dataset and keep looping.
After executing code I get this output:
Notice value 2 returns nothing because it does not exist in any of the other sheets.

Make columns and rows mandatory

i need to make rows and columns mandatory before close
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lr As Long
Dim r As Long
' Activate correct sheet
' Sheets("Sheet1").Activate
' Find last row in column A with data
lr = Cells(Rows.Count, "A").End(xlUp).Row
' Loop through all rows with data in column A
For r = 2 To lr
' Check to see if column A is not zero
If Cells(r, "A") <> 0 Then
' Check to see that columns B and C are not empty
If Cells(r, "B") = "" Or Cells(r, "C") = "" Then
Cancel = True
MsgBox "Please fill in columns B and C", vbOKOnly, "ROW " & r & " INCOMPLETE!!!"
End If
End If
Next r
End Sub
I made it a bit faster and more user friendly using:
Arrays to iterate data.
a single error message at the end rather than several.
I also made the requested change to allow code to work with and column width requirements. Just change the ColumnsToCheck = 6 to however many columns.
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim lRow As Long
Dim I As Long
Dim ColumnsToCheck As Long
Dim MissedItem As Boolean
Dim Mitem As Boolean
Dim M As Long
Dim SrcRG As Range
Dim SrcArr
Dim OutMessage As String
' *** This is the number of columns you are checking INCLUDING Column A
ColumnsToCheck = 6 'Minimum = 2
' Find last row in column A with data
lRow = Cells(Rows.Count, "A").End(xlUp).Row
Set SrcRG = Range("A1").Resize(lRow, ColumnsToCheck)
SrcArr = SrcRG
MissedItem = False
OutMessage = "Please fill in data columns 2 through " & ColumnsToCheck & "." & vbCrLf & _
"Missing Data found in the following locations." & vbCrLf
' Loop through all rows with data in column A
For I = 2 To lRow
' Check to see if column A is not zero
If SrcArr(I, 1) <> 0 Then
' Check to see that columns B and C are not empty
For M = 2 To ColumnsToCheck
Debug.Print SrcArr(I, M)
If SrcArr(I, M) = "" Then Mitem = True
Next M
If Mitem = True Then
MissedItem = True
OutMessage = OutMessage & vbCrLf & _
" Missing data at row # " & I
Mitem = False
End If
End If
Next I
If MissedItem = True Then
Cancel = True
MsgBox OutMessage, vbOKOnly, "Error: Missing Data"
End If
End Sub

Why is my array returning empty? And how do I ensure it copies the data into my third selection

After countless efforts to keep the array "newvarray" within range, I am now running into a result of an empty array from a 278 line column. I believe this is also the root cause of my endgame function not executing (pasting unmatched values into the rolls sheet)?
Clarification: the actualy empty cells report on locals as "Empty", the columns with string report as " "" "
Dim oldsht As Worksheet
Dim newsht As Worksheet
Dim rollsht As Worksheet
Dim a As Integer
Dim b As Integer
Dim c As Integer
Set oldsht = ThisWorkbook.Sheets("Insert Yesterday's Report Here")
Set newsht = ThisWorkbook.Sheets("Insert Today's Report Here")
Set rollsht = ThisWorkbook.Sheets("Rolls")
Dim OldVArray(), NewVArray(), RollArray() As String
ReDim Preserve OldVArray(1 To oldsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 5 To 5)
ReDim Preserve NewVArray(2 To newsht.Range("a" & Rows.Count).End(xlUp).Row, 5 To 5)
ReDim Preserve RollArray(1 To rollsht.Range("a" & Rows.Count).End(xlUp).Row - 1, 3 To 3)
For a = 2 To oldsht.Range("E" & Rows.Count).End(xlUp).Row
OldVArray(a, 5) = oldsht.Cells(a, 5)
Next a
For b = 2 To newsht.Range("E" & Rows.Count).End(xlUp).Row
NewVArray(b, 5) = newsht.Cells(b, 5)
Next b
For c = 2 To rollsht.Range("C" & Rows.Count).End(xlUp).Row
RollArray(c, 3) = rollsht.Cells(c, 3)
Next c
Dim Voyage As String
For a = 2 To UBound(OldVArray)
Voyage = OldVArray(a, 5)
For b = 2 To UBound(NewVArray)
voyage2 = NewVArray(b, 5)
If voyage2 <> Voyage Then
If voyage2 <> "" Then
For Each cell In NewVArray
voyage2 = rollsheet.Range("C:C")
Next
End If
End If
Next
Next
Here are snips of sample idea, highlighted are the rows that need to be found, and the voyage that changed is in orange. Third on Rolls would be the output of the macro.
Oldsheet:
Newsheet:
Rolls:
Untested, but this is how I'd do it. Just going from your screenshots. If your actual data looks different then you will need to make some adjustments.
Sub test()
Dim wb As Workbook, oldsht As Worksheet, newsht As Worksheet, rollsht As Worksheet
Dim c As Range, id, col, cDest As Range, copied As Boolean, m
Set wb = ThisWorkbook
Set oldsht = wb.Sheets("Insert Yesterday's Report Here")
Set newsht = wb.Sheets("Insert Today's Report Here")
Set rollsht = wb.Sheets("Rolls")
'next empty row on Rolls sheet
Set cDest = rollsht.Cells(Rows.Count, "A").End(xlUp).Offset(1)
'loop colA on new sheet
For Each c In newsht.Range("A2:A" & newsht.Cells(Rows.Count, "A").End(xlUp).row).Cells
id = c.Value 'identifier from Col A
If Len(id) > 0 Then
m = Application.Match(id, oldsht.Columns("A"), 0) 'check for exact match on old sheet
If Not IsError(m) Then
'got a match: check for updates in cols B to C
copied = False
For col = 2 To 3
If c.EntireRow.Cells(col).Value <> oldsht.Cells(m, col).Value Then
If Not copied Then 'already copied this row?
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy changed row
Set cDest = cDest.Offset(1) ' next empy row
copied = True
End If
cDest.EntireRow.Cells(col).Interior.Color = vbRed 'flag updated value
End If
Next col
Else
cDest.Resize(1, 3).Value = c.Resize(1, 3).Value 'copy new row
Set cDest = cDest.Offset(1) ' next empy row
End If
End If
Next c
End Sub

copy, paste, transpose rows with pictures

I have a macro that copies and pastes rows from input sheet to output sheet. I find PRODUCT NAME and END DATE, then copy the whole row and transpose when pasting it. I am using transpose because I want to have vertical table.
I have a problem with images because I don't know how to copy them to proper cell so they match with Name and Date. I've managed to write a script that is copying and pasting images but it puts all of them in cell A1. When I want to add range to target_sheet.Paste I am getting vba method intersect of object _application failed error.
Below you can see how input and output sheets look.
Input sheet:
Expected output sheet (with only 3 columns) :
It is very important to know that 'input' sheet contains many products with names, prices and images and there is always a blank row between them. The number of images in each row can be different (from 1 to 25).
Sub copy_paste()
Dim Cell As Range
Dim src_rng As String
Dim LR As Long
Dim source_sheet As Worksheet
Dim target_sheet As Worksheet
Dim pic As Shape
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
target_sheet.Cells.Delete
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A10000").End(xlUp).Row + 1
If Cell.Value = "Name" Then
Cell.EntireRow.Copy
target_sheet.Range("A" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste, transpose end line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("B10000").End(xlUp).Row + 1
If Cell.Value = "Date" Then
Cell.EntireRow.Copy
target_sheet.Range("B" & LR).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End If
Next
'copy paste image
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("C10000").End(xlUp).Row + 1
If Cell.Value = "Image" Then
For Each pic In source_sheet.Shapes
If Not Application.Intersect(pic.TopLeftCell, Range(src_rng)) Is Nothing Then
pic.CopyPicture
target_sheet.Paste
End If
Next pic
End If
Next
Application.ScreenUpdating = True
End Sub
Please, try the next code. It follows the logic deduced from your last question edit, respectively: the former "Name" becomes "Product Name", "Date" becomes "End Date" and the row keeping the pictures is the one below "Product Name" row. It is able to process two or three product names/pictures per group:
Sub copy_paste()
Dim Cell As Range, src_rng As String, LR As Long
Dim source_sheet As Worksheet, target_sheet As Worksheet
Dim pic As Shape, arrPAddr, rngTr As Range, k As Long
Dim cellRHeight As Range, nrShapesPerRange As Long 'to be 2 or 3
nrShapesPerRange = 2 'Choose here initial number of shapes per row (2 or 3)
'worksheet with source data
Set source_sheet = ThisWorkbook.Sheets("input")
'worksheet with newly created template
Set target_sheet = ThisWorkbook.Sheets("output")
'range of cells I want to check
src_rng = "A14:A26"
Application.ScreenUpdating = False
ReDim arrPAddr(1 To 2, 1 To source_sheet.Shapes.count): k = 1
target_sheet.cells.Delete: For Each pic In target_sheet.Shapes: pic.Delete: Next
'copy paste, transpose product line rows
For Each Cell In source_sheet.Range(src_rng)
LR = target_sheet.Range("A" & rows.count).End(xlUp).row + 1
If Cell.value = "Product Name" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("A" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
arrPAddr(1, k) = Cell.Offset(1, 1).Address
arrPAddr(2, k) = rngTr.Offset(, 2).Address: k = k + 1
arrPAddr(1, k) = Cell.Offset(1, 2).Address
arrPAddr(2, k) = rngTr.Offset(1, 2).Address: k = k + 1
If nrShapesPerRange = 3 Then
arrPAddr(1, k) = Cell.Offset(1, 3).Address
arrPAddr(2, k) = rngTr.Offset(2, 2).Address: k = k + 1
End If
If cellRHeight Is Nothing Then Set cellRHeight = Cell.Offset(1)
End If
LR = target_sheet.Range("B" & rows.count).End(xlUp).row + 1
If Cell.value = "End Date" Then
source_sheet.Range(Cell.Offset(, 1), Cell.Offset(, 3)).Copy
Set rngTr = target_sheet.Range("B" & LR)
rngTr.PasteSpecial Paste:=xlAll, Transpose:=True
End If
Next
ReDim Preserve arrPAddr(1 To 2, 1 To k - 1)
'Making the row height in target_sheet equal to source_sheet column with:
target_sheet.Range("2:" & LR + 3).EntireRow.RowHeight = source_sheet.Range("A16").EntireRow.RowHeight
target_sheet.Range("A:C").EntireColumn.AutoFit
target_sheet.Range("C1").EntireColumn.ColumnWidth = cellRHeight.EntireColumn.ColumnWidth
'copy paste image:
Dim i As Long
For Each pic In source_sheet.Shapes
For i = 1 To UBound(arrPAddr, 2)
If pic.TopLeftCell.Address = arrPAddr(1, i) Then
pic.Copy: target_sheet.Paste
With target_sheet.Shapes(target_sheet.Shapes.count)
.top = target_sheet.Range(arrPAddr(2, i)).top + (target_sheet.Range(arrPAddr(2, i)).RowHeight - pic.height) / 2
.left = target_sheet.Range(arrPAddr(2, i)).left
End With
Exit For
End If
Next i
Next
Application.ScreenUpdating = True
target_sheet.Activate
MsgBox "Ready..."
End Sub
Plese, test the code and send some feedback

Change the font color in a cell based on the value in another cell

I would like to change the color of certain text in the cells based on the values in another cells. I have tried using conditional formatting but it does not work since I only wanted to change the color of particular words in the cells. I have googled a few VBA codes as well but still could not find the right one. Is there any VBA Code to enable this?
As shown in the example below (see image), I want to highlight ONLY the dates in Column B and C that match the dates in Column G. The day should remain the same.
For information, the values in Column B and C are formatted as text and the values in G are formatted as date.
Before
and this is basically what I wish for.
After
I have modified code appropriately as per your requirement in the comment.
Sub Change_Text_Color()
Dim Find_Text, Cell, Cell_in_Col_G, LastCell_inColG As Range
Dim StartChar, CharLen, LastUsedRow_inRange, LastUsedRow_inColB, _
LastUsedRow_inColC As Integer
LastUsedRow_inColB = Sheet1.Cells(Rows.count, "B").End(xlUp).Row
LastUsedRow_inColC = Sheet1.Cells(Rows.count, "C").End(xlUp).Row
LastUsedRow_inRange = Application.WorksheetFunction. _
Max(LastUsedRow_inColB, LastUsedRow_inColC)
Set LastCell_inColG = Sheet1.Cells(Rows.count, "G").End(xlUp)
For Each Cell In Range(Sheet1.Cells(2, 2), Cells(LastUsedRow_inRange, 3))
For Each Cell_in_Col_G In Range(Sheet1.Cells(2, 7), LastCell_inColG)
CharLen = Len(Cell_in_Col_G.Text)
Set Find_Text = Cell.Find(what:=Cell_in_Col_G.Text)
If Not Find_Text Is Nothing Then
StartChar = InStr(Cell.Value, Cell_in_Col_G.Text)
With Cell.Characters(StartChar, CharLen)
.Font.Color = RGB(0, 255, 0)
End With
End If
Next
Next
End Sub
Please let me know your feedback on it.
Use Characters:
With Range("a1")
.Characters(Start:=1, Length:=4).Font.Color=0
.Characters(Start:=5, Length:=10.Font.Color=255
End With
colours the first four letters black and the next ten in red.
Ref:
https://learn.microsoft.com/en-us/office/vba/api/excel.characters
I find filtering works well in these scenarios. Assuming that the format of your sheet is as it is in your sample sheets, try the code below:
Sub MarkDatesInCells()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
' Turn off updating
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Clear autofilter if exists
If .AutoFilterMode Then .AutoFilterMode = False
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
.UsedRange.AutoFilter iC, "=*" & oHighlightRng.Value
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
.AutoFilterMode = False
Next
Next
End With
' Turn on updating
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
EDIT
Based on your requirement to have this solution for a sheet with a table connected to a database, try the below code. I don't have a database that I can test the below code on so you might have to tinker with it a bit to get it right (i.e. the text that is highlight)
Sub MarkDatesInCellsInATable()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
Dim oTable As ListObject: Set oTable = oWS.ListObjects("Table_ExceptionDetails.accdb") '<- Change to the table name
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Reset autofilter
oTable.Range.AutoFilter
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
oTable.Range.AutoFilter iC, "=*" & oHighlightRng.Value & "*"
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
oTable.Range.AutoFilter
Next
Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Resources