How do I change the first 3 characters and "CLEARANCE" Font to BOLD of cells containing "T##-" and loop it until the last row of STANDARD and NON-STANDARD tables
Sub Formatting()
Dim StartCell As Range
Set StartCell = Range("A15")
Dim myList As Range
Set myList = Range("A15:A" & Range("A" & Rows.Count).End(xlUp).Row)
Dim x As Range
For Each x In myList
'myList.ClearFormats
x.Font.Bold = False
If InStr(1, x.Text, "CLEARANCE") > 0 Or InStr(1, x.Text, "clearance") > 0 Then
x.Font.Bold = True
Else
x.Font.Bold = False
End If
Next
For Each x In myList
'myList.ClearFormats
x.Font.Bold = False
If InStr(1, x.Text, "T*") > 0 Then
x.Font.Bold = True
Else
x.Font.Bold = False
End If
Next
End Sub
ORIG
FORMATTED
Here is one way to achieve what you want which I feel is faster (I could be wrong). This way lets Excel do all the dirty work :D.
Let's say our data looks like this
LOGIC:
Identify the worksheet you are going to work with.
Remove any autofilter and find last row in column A.
Construct your range.
Filter the range based on "=T??-*" and "=*CLEARANCE*".
Identify the filtered range.
Check if there was anything filtered and if it was, then do a Find and Replace
Search for "CLEARANCE" and replace with bold tags around it as shown in the code.
Loop through the filtered range to create an html string and then copy to clipboard
Finally paste them back.
CODE:
Is this what you are trying? I have commented the code so you should not have a problem understanding it but if you do them simply ask :)
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range, rngFinal As Range, aCell As Range
Dim htmlString As Variant
'~~> Set this to the relevant Sheet
Set ws = Sheet1
With ws
'~~> Remove any autofilter
.AutoFilterMode = False
'~~> Find last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Construct your range
Set rng = .Range("A1:A" & lRow)
'~~> Filter the range
With rng
.AutoFilter Field:=1, Criteria1:="=T??-*", _
Operator:=xlAnd, Criteria2:="=*CLEARANCE*"
'~~> Set the filtered range
Set rngFinal = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
End With
'~~> Check if there was anything filtered
If Not rngFinal Is Nothing Then
rngFinal.Replace What:="CLEARANCE", Replacement:="<b>CLEARANCE</b>", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
'~~> Loop through the filtered range and add
'~~> ending html tags and copy to clipboard and finally paste them
For Each aCell In rng.SpecialCells(xlCellTypeVisible)
If aCell Like "T??-*" Then
htmlString = "<html><b>" & _
Left(aCell.Value2, 4) & "</b>" & _
Mid(aCell.Value2, 5) & "</html>"
With CreateObject("htmlfile")
With .parentWindow.clipboardData
Select Case True
Case Len(htmlString): .setData "text", htmlString
Case Else: .GetData ("text")
End Select
End With
End With
DoEvents
aCell.PasteSpecial xlPasteAll
End If
Next aCell
End If
'~~> Remove any filters
ws.AutoFilterMode = False
End Sub
OUTPUT:
NOTE: If you want to bold either of the text when one of them is absent then change Operator:=xlAnd to Operator:=xlOr in the above code.
I thought I'd chuck in this solution based on regex. I was fiddling around a long time trying to use the Submatches attributes, but since they do not have the FirstIndex() and Lenght() properties, I had no other option than just using regular matching objects and the Like() operator:
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim rng As Range, cl As Range, lr As Long
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:A" & lr)
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\bCLEARANCE\b"
For Each cl In rng
If cl.Value Like "T[0-9][0-9]-*" Then
cl.Characters(0, 3).Font.Bold = True
If .Test(cl.Value) Then
Set M = .Execute(cl.Value)
cl.Characters(M(0).firstindex + 1, M(0).Length).Font.Bold = True
End If
End If
Next
End With
End Sub
The Like() operator is there just to verify that a cell's value starts with a capital "T", two digits followed by an hyphen. This syntax is close to what regular expressions looks like but this can be done without a call to the regex-object.
When the starting conditions are met, I used a regex-match to test for the optional "CLEARANCE" in between word-boundaries to assert the substring is not part of a larger substring. I then used the FirstIndex() and Lenght() properties to bold the appropriate characters.
The short and easy, but not fast and flexible approach. "Bare minimum"
No sheet specified, so uses active sheet. Will ignore multiple instances of "CLEARANCE", will loop everything (slow), ingores starting pattern (only cares if it starts with "T"), doesn't remove any bold text from things that shouldn't be bold.
Sub FormattingLoop()
Dim x As Range
For Each x In Range("A15:A" & Cells(Rows.Count, "A").End(xlUp).Row)
If Left(x, 1) = "T" Then x.Characters(, 3).Font.FontStyle = "Bold"
If InStr(UCase(x), "CLEARANCE") > 0 Then x.Characters(InStr(UCase(x), "CLEARANCE"), 9).Font.FontStyle = "Bold"
Next x
End Sub
Related
So here's the code. I have a calendar with dates in B4:H9. I want to change the color of the cells if the those dates are in a list (column, on different worksheet).
This might be a bit heavy to run if there are many different dates in the worksheet, but that doesn't matter.
What am I doing wrong here? It keeps giving me different error codes, when trying different things.
Sub check_Click()
Dim area As Range
Dim item1 As Range
Dim item2 As Range
Dim sheet As Worksheet
Dim columnlist As Range
sheet = Range("E2").Value
area = Range("B4:H9")
columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)
For Each item1 In area
For Each item2 In columnlist
If item1.Value = item2.Value Then
item1.Interior.ColorIndex = RGB(255, 255, 0)
End If
Next item2
Next item1
End Sub
As SuperSymmetry mentioned, when you define objects (e.g. ranges, sheets) you need to use the Set keyword. I will not get into that explanation. However few things that I would like to mention...
Try and give meaningful variable names so that you can understand what are they for.
Work with objects so that your code knows which sheet, which range are you referring to.
No need of 2nd loop. Use .Find to search for your data. It will be much faster
To set RGB, you need .Color and not .ColorIndex
Is this what you are trying? (Untested)
Option Explicit
Sub Check_Click()
Dim rngData As Range
Dim rngReference As Range
Dim aCell As Range
Dim matchedCell As Range
Dim ws As Worksheet
Dim lastRow As Long
Dim worksheetName As String
'~~> Change the sheet name accordingly
worksheetName = ThisWorkbook.Sheets("Sheet1").Range("E2").Value
Set ws = ThisWorkbook.Sheets(worksheetName)
With ws
'~~> Find the last row in Col A
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rngData = .Range("B4:H9")
Set rngReference = .Range("A2:A" & lastRow)
'~~> Loop through your data and use .Find to check if the date is present
For Each aCell In rngData
Set matchedCell = rngReference.Find(What:=aCell.Value, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not matchedCell Is Nothing Then
'~~> Color the cell
matchedCell.Interior.Color = RGB(255, 255, 0)
End If
Next aCell
End With
End Sub
This should do the trick, I don't like leaving ranges without their sheet, but since I believe you are using a button, there should be no problem:
Option Explicit
Sub check_Click()
'We are going to use a dictionary, for it to work you need to:
'Go to Tools-References-Check the one called: Microsoft Scripting Runtime
Dim DatesToChange As Dictionary: Set DatesToChange = LoadDates
Dim area As Range: Set area = Range("B4:H9")
Dim item As Range
For Each item In area
If DatesToChange.Exists(item.Value) Then
item.Interior.Color = RGB(255, 255, 0)
End If
Next item
End Sub
Private Function LoadDates() As Dictionary
Set LoadDates = New Dictionary
Dim arr As Variant: arr = ThisWorkbook.Sheets(Range("E2")).Range("A:A")
Dim i As Long
For i = 2 To UBound(arr)
'This here will break the loop when finding an empty cell in column A
If arr(i, 1) = vbNullString Then Exit For
'This will add all your dates in a dictionary (avoiding duplicates)
If Not LoadDates.Exists(arr(i, 1)) Then LoadDates.Add arr(i, 1), 1
Next i
End Function
When you define objects (e.g. ranges, sheets) you need to use the Set keyword
Set area = Range("B4:H9")
Set columnlist = Worksheets(sheet).Range("A2:A" & Rows.Count)
Worksheets() accepts either an Integer or a String. Therefore, sheet should be of Type String
Dim sheet As String
You're also setting columnlist to the whole column in the sheet so you're looping hundreds of thousands more times unncessarily. Change it to
With Worksheets(sheet)
Set columnlist = .Range(.Range("A2"), .Range("A" & Rows.Count).Offset(xlUp))
End With
The above should fix the errors in your code and make it run a little faster. However, there's still big room for improvment in the efficiency of the code. For example, instead of changing the colour inside the loop, you should build a range and set the colour one time after the loop.
Also consider resetting the colour at the beginning of the code with
area.Interior.Pattern = xlNone
I would personally go with conditional formatting as #SiddharthRout suggested in the comments.
Edit following comment
Here's my rendition
Sub check_Click()
Dim dStart As Double
dStart = Timer
Dim rngCalendar As Range
Dim vCalendar As Variant
Dim shtDates As Worksheet
Dim vDates As Variant, v As Variant
Dim i As Long, j As Long
Dim rngToColour As Range
' Change the sheet name
With ThisWorkbook.Sheets("Calendar")
Set rngCalendar = .Range("B4:H9")
vCalendar = rngCalendar.Value
Set shtDates = ThisWorkbook.Sheets(.Range("E2").Value)
End With
With shtDates
vDates = .Range(.Range("A2"), .Range("A" & Rows.Count).End(xlUp)).Value
End With
For i = 1 To UBound(vCalendar, 1)
For j = 1 To UBound(vCalendar, 2)
For Each v In vDates
If v <> vbNullString And v = vCalendar(i, j) Then
If rngToColour Is Nothing Then
Set rngToColour = rngCalendar.Cells(i, j)
Else
Set rngToColour = Union(rngToColour, rngCalendar.Cells(i, j))
End If
Exit For
End If
Next v
Next j
Next i
rngCalendar.Interior.Pattern = xlNone
If Not rngToColour Is Nothing Then
rngToColour.Interior.Color = RGB(255, 255, 0)
End If
MsgBox "Time taken: " & Format(Timer - dStart, "0.0000s")
End Sub
With a list of 2500 dates it took 0.0742s on my machine.
I have a code that's not working yet.
It is supposed to open an input window where you can enter a text.
Then it should open an window where you can enter the range.
After both entries the whole workbook should be searched and the whole cell where the partial text is located should be marked bold.
If the cell contains more text than the one you are looking for, it should be marked bold.
Example in the cell there is the text:
"Export Area Asia"
If I only enter "Export Area" in the input window, the cell containing "Export Area Asia" should be marked completely bold.
Here is my code so far:
Sub Zelle_Fett_Wenn_best_Inhalt_Input_Box()
Dim Filtertext As String
Dim ws As Worksheet
Dim aRange As Range
On Error Resume Next
Set aRange = Application.InputBox(prompt:="Enter range", Type:=8)
If aRange Is Nothing Then
MsgBox "Operation Cancelled"
Else
aRange.Select
End If
Filtertext = InputBox("Enter Text")
For Each ws In Worksheets
ws.Select
x = ActiveSheet.UsedRange.Rows.Count
Rows.Select
If Cells.Value Like Filtertext Then
Selection.Font.Bold = True
Else
Selection.Font.Bold = False
End If
Next ws
End Sub
Maybe somebody would be so nice to correct it so that it works.
Thanks a lot and cheers
Tom
So as per my comment, I'd advise against using .Select or UsedRange. Instead get your last used row and column dynamically. Furthermore, you are missing wildcards in your Like operator plus you'd want to iterate over your whole Range object.
Next, I'd say you could skip iteration and either use conditional formatting OR use ReplaceFormat, for example:
Sub Test()
Dim lr As Long, lc As Long, rng As Range, ws As Worksheet, FilterText As String
FilterText = InputBox("Enter Text")
If FilterText = "" Then Exit Sub
For Each ws In ThisWorkbook.Worksheets
'Get last used row and column
lr = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
'Set your range object
Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lr, lc))
'Set your ReplaceFormat
With Application.ReplaceFormat
.Clear
.Font.Bold = True
End With
'Replace formatting to cells with right criteria
rng.Font.Bold = False
rng.Replace What:="*" & FilterText & "*", Replacement:="", SearchFormat:=False, ReplaceFormat:=True
Next ws
End Sub
I left out aRange since I noticed you never even use it.
I have the following code which should simply select a range of rows and delete them. Unfortunately it deletes the headers as well, no matter how I change the range.
I tried to change the "rng" parameter without success.
Thank you for the feedback you can provide.
Sub delete_rows_range()
'Application.ScreenUpdating = False
Dim rng, Rng_del As Range
Dim leg As Range
Set leg = Worksheets("Sheet1").Range("aB1")
Set rng = Worksheets("Sheet1").Range("b1")
If Worksheets("Sheet1").AutoFilterMode = True Then
Worksheets("Sheet1").AutoFilter.ShowAllData
End If
rng.Select
rng.AutoFilter Field:=2, Criteria1:=leg
'rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.delete
rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select
Worksheets("Sheet1").AutoFilterMode = False
End Sub
Your problem is that you are using a single cell as the range.
When you .Offset a single cell range, then use `xlCelTypeVisible.EntireRow.Delete
Excel selects every cell on the sheet and deletes them.
You really should clarify your range with a properly defined range object. e.g.
Dim ws As Worksheet, lRow As Long, rng As Range
Set ws = Worksheets("Sheet1")
lRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ws.Range("A1:AB" & lRow)
But if you want to use B1 as your rng you can replace your line, rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Select with this line...
rng.Range(Cells(2, 2), Cells(rng.Rows.Count, 2)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
You are trying to select from a single cell range.
You should do instead:
Sub delete_rows_range()
'Application.ScreenUpdating = False
Dim rng, Rng_del As Range
Dim leg As Range
Set leg = Worksheets("Sheet1").Range("AB1")
Set rng = Worksheets("Sheet1").Range("B1")
If Worksheets("Sheet1").AutoFilterMode = True Then
Worksheets("Sheet1").AutoFilter.ShowAllData
End If
rng.Select
rng.AutoFilter Field:=2, Criteria1:=leg
'rng.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.delete
Worksheets("Sheet1").UsedRange.SpecialCells(xlCellTypeVisible).Rows(2).Select
Worksheets("Sheet1").AutoFilterMode = False
End Sub
I have this sub to delete a row when certain criteria is met. However, I find it taking way too much time to run. Is there any way I could make this run any faster?
'This sub deletes the row that has any of the following values
Dim ws As Worksheet, i&, lastrow&, value$
Set ws = ActiveWorkbook.Sheets("Product Qty")
lastrow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = lastrow To 2 Step -1
value = ws.Cells(i, 2).value
' Check if it contains one of the keywords.
If (value Like "*VOI*" _
Or value Like "*SLOC*" _
Or value Like "*NCM*" _
Or value Like "*RTS*" _
Or value Like "*VND*" _
Or value Like "*DFFC*" _
Or value Like "*STOR*") _
Then
' Protected values found. Delete the row.
ws.Rows(i).delete
End If
Next
Application.ScreenUpdating = True
Two things that make your code faster:
Read your data into an array and loop through that array instead of a range. Looping through arrays is faster than looping through ranges.
Collect all the rows you want to delete in a range variable RowsToDelete using the Application.Union method and delete them all at once in the end.
Note that I recommend not to use Value as a variable name as this could easily confuse with the .Value property of a range.
Option Explicit
Sub DeleteRows()
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Product Qty")
Dim LastRow As Long
LastRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
'read data into array
DataArr() As Variant
DataArr = ws.Range("B1", "B" & LastRow).value
Dim ChkVal As String
'we collect all rows in a range using union
Dim RowsToDelete As Range
Dim iRow As Long
For iRow = 2 To UBound(DataArr, 1)
ChkVal = DataArr(iRow, 1)
' Check if it contains one of the keywords.
If (ChkVal Like "*VOI*" _
Or ChkVal Like "*SLOC*" _
Or ChkVal Like "*NCM*" _
Or ChkVal Like "*RTS*" _
Or ChkVal Like "*VND*" _
Or ChkVal Like "*DFFC*" _
Or ChkVal Like "*STOR*") Then
' Protected values found.
If RowsToDelete Is Nothing Then 'first row
Set RowsToDelete = ws.Rows(iRow)
Else 'all following rows
Set RowsToDelete = Union(RowsToDelete, ws.Rows(iRow))
End If
End If
Next
'delete all rows
If Not RowsToDelete Is Nothing Then RowsToDelete.Delete
End Sub
If you need multiple wildcard criteria, you can do it by an autofilter also:
put filter criteria in a range (on a separate sheet)
use the range for an autofilter
delete all rows
The criteria-rows are OR-combined and can be placed anywhere on a different worksheet:
By following, above critera defines all rows to be deleted:
Private Sub DeleteRowsFast()
Dim ws As Worksheet, fs As Worksheet
Set ws = ActiveSheet
Set fs = Sheets("FilterSheet")
ws.UsedRange.AdvancedFilter _
Action:=xlFilterInPlace, _
CriteriaRange:=fs.Range("Filter1"), _
Unique:=False
ws.Rows("2:1000000").Delete Shift:=xlUp ' delete visible rows
ws.ShowAllData
End Sub
I have a spreadsheet that is generated as a report in our Enterprise system and downloaded into an Excel spreadsheet. Blank cells in the resulting spreadsheet are not really blank, even though no data is present - and the blank cells do Not contain a 'space' character.
For example, the following cell formula in A2 returns TRUE (if A1 is a blank cell):
=IF(A1="","TRUE","FALSE")
However,
=ISBLANK(A1)
returns FALSE.
You can replicate this problem by typing an apostrophe (') in a cell and copying the cell. Then, use Paste Special...Values to paste to another cell and the apostrophe is not visible in the pasted cell, nor in the Formula Bar. There appears to be a clear cell, but it will evaluate to FALSE using ISBLANK.
This causes sorting to result in the fake blank cells at the top of an ascending sort, when they need to be at the bottom of the sort.
I can use a vba loop to fix the fake blanks, to loop through every column and evaluate
IF Cell.VALUE = "" Then
Cell.Clear
but because the spreadsheet has tens of thousands of rows of data and as many as 50 columns, this adds substantial overhead to the program and I would prefer to use FIND and Replace.
Here is the code that does not currently work:
Range("ZZ1").Copy
Range("Table1[#All]").Select
With Selection
.Replace What:="", Replacement:=.PasteSpecial(xlPasteValues, xlNone, False, False), _
LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
End With
The following things do not work to clear the fake blank cells either:
Replacement:= vbnullstring
Replacement:= ""
Replacement:= Cells.Clear
Replacement:= Cells.ClearContents
Replacement:= Cells.Value = ""
I have tried 20 other things that do not work either.
Try this
With ActiveSheet.UsedRange
.NumberFormat = "General"
.Value = .Value
End With
A variant array provides an efficient way of handling the false empties:
Sub CullEm()
Dim lngRow As Long
Dim lngCol As Long
Dim X
X = ActiveSheet.UsedRange.Value2
For lngRow = 1 To UBound(X, 1)
For lngCol = 1 To UBound(X, 2)
If Len(X(lngRow, lngCol)) = 0 Then X(lngRow, lngCol) = vbNullString
Next
Next
ActiveSheet.UsedRange.Value2 = X
End Sub
The problem is that you are searching for a hidden .PrefixCharacter which are not covered by the standard replacement function. For more information on this you might want to visit MSDN: https://msdn.microsoft.com/en-us/library/office/ff194949.aspx
In order to find and replace these you'll have to use the .Find function because it can look at the formulas (rather than only at a cell's value). Here is a short sample code to illustrate that:
Option Explicit
Public Sub tmpTest()
Dim cell As Range
Dim rngTest As Range
Dim strFirstAddress As String
Set rngTest = ThisWorkbook.Worksheets(1).Range("A1:G7")
Set cell = rngTest.Find("", LookIn:=xlFormulas, lookat:=xlPart)
If Not cell Is Nothing Then
strFirstAddress = cell.Address
Do
cell.Value = vbNullString
Set cell = rngTest.FindNext(cell)
Loop While strFirstAddress <> cell.Address And Not cell Is Nothing
End If
End Sub
I can't figure out anything that you could put in Replacement to get that to work. I'm afraid you're stuck looping. You can reduce the overhead by using .Find instead of looping through every cell.
Sub ClearBlanks()
Dim rng As Range
Dim rFound As Range
Dim sFirstAdd As String
Dim rFoundAll As Range
Set rng = Sheet1.UsedRange
Set rFound = rng.Find(vbNullString, , xlValues, xlWhole)
If Not rFound Is Nothing Then
sFirstAdd = rFound.Address
Do
If rFoundAll Is Nothing Then
Set rFoundAll = rFound
Else
Set rFoundAll = Application.Union(rFound, rFoundAll)
End If
Set rFound = rng.FindNext(rFound)
Loop Until rFound.Address = sFirstAdd
End If
If Not rFoundAll Is Nothing Then
rFoundAll.ClearContents
End If
End Sub
You can use the table filter to select the (seemingly) blank cells in each column and clear the contents. This should be quicker than finding each blank cell.
Sub clearBlankTableEntries()
Dim tbl As ListObject, c As Byte
Set tbl = ActiveSheet.ListObjects("testTable")
For c = 1 To tbl.Range.Columns.Count
tbl.Range.AutoFilter Field:=c, Criteria1:="="
Range(tbl.Name & "[Column" & c & "]").ClearContents
tbl.Range.AutoFilter Field:=c
Next c
End Sub