Public Function highlight_text(Search)
Dim rng As Range
Dim cell As Range
Set rng = Range("A2:H32")
For Each cell In rng
If cell.text = Search Then
cell.Font.ColorIndex = 3
cell.Font.Name = "Arial"
cell.Font.Size = 14
cell.Font.Bold = True
Else
cell.Font.Bold = False
cell.Font.Size = 11
cell.Font.ColorIndex = 1
End If
Next cell
End Function
The above function is called on 'mouseover' a cell, it manages to set the proper cells to RED color but it won't make the text bold
You cannot call a function from the worksheet and change the format of a cell.
(The fact that even the color is changing is perplexing)
As this does not need to be a function, it does not return anything and you cannot use it from the worksheet, we can make it a sub:
Public Sub highlight_text(Search)
Dim rng As Range
Dim cell As Range
Set rng = Range("A2:H32")
For Each cell In rng
If cell.Text = Search Then
cell.Font.ColorIndex = 3
cell.Font.Name = "Arial"
cell.Font.Size = 14
cell.Font.Bold = True
Else
cell.Font.Bold = False
cell.Font.Size = 11
cell.Font.ColorIndex = 1
End If
Next cell
End Sub
Use a Worksheet_Change Event(or some other event) to call the sub:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("A2:H32")) Is Nothing Then
highlight_text (Target.Text)
End If
End Sub
Put both of these in the worksheet code in which you want the code to run.
This will now highlight the like cells as you click on any cell in the range.
This is a good solution in this case. But I am confused by the statement that you cannot change to format of a cell in a function. Tried this to confirm. It works fine.
Function boldit() As String
Dim theCell As String
theCell = "Q8"
Range(theCell).Value = "XorY"
Range(theCell).Font.Color = RGB(255, 0, 0)
Range(theCell).Font.Bold = True
End Function
The reason I'm interested is that in a real function I have written the same .Font.Bold statement does not work (while the .Font.Color does)
Any other idea why .Font.Bold=True might not work
Related
I'm trying to write some VBA code that will unhide an entire row if another specific row is hidden. This macro also hides a range of rows based on the value in a specific column. This aspect works fine - I have reliable code. I can't get the first function I described to work. Should be easy to do, just don't know the syntax. This subroutine should execute upon opening the workbook.
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Dim targ As Range
Dim msg As Range
targ = "DETAILS!B6"
msg = "DETAILS!B42"
msg.EntireRow.Hidden = True
With Range("DETAILS!B6:B40")
.EntireRow.Hidden = False
For Each cell In Range("DETAILS!B6:B40")
Select Case cell.Value
Case Is = 0
cell.EntireRow.Hidden = True
End Select
Next cell
End With
If targ.EntireRow.Hidden = True Then
msg.EntireRow.Hidden = False
End If
Application.ScreenUpdating = True
End Sub
You need to set the variables like below
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Dim targ As Range
Dim msg As Range
Set targ = "DETAILS!B6"
Set msg = "DETAILS!B42"
msg.EntireRow.Hidden = True
With Range("DETAILS!B6:B40")
.EntireRow.Hidden = False
For Each cell In Range("DETAILS!B6:B40")
Select Case cell.Value
Case Is = 0
cell.EntireRow.Hidden = True
End Select
Next cell
End With
If targ.EntireRow.Hidden = True Then
msg.EntireRow.Hidden = False
End If
Application.ScreenUpdating = True
End Sub
Oh! Just put Set before targ and msg since they're a Range. When declaring ranges, you have to have Set, i.e. Set myRng = Range("A1:A10").
You might need to do Set targ = Range("Details!B6") if just Set Targ = "DetailsB6" doesn't work.
On second thought, I don't think Set Targ = "Details!B6" will work if you are Dim Targ as Range. You're dim'ing as a Range, but are declaring it as like a string. You need this to be a Range, to use it like targ.EntireRow.Hidden, etc.
Though you can call range objects like this : Range("DETAILS!B6:B40")
In vba it is better accepted to call it like this: Sheets("DETAILS").Range("B6:B40")
I fixed a few more syntax errors:
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Dim targ As Range
Dim msg As Range
Set targ = Sheets("DETAILS").Range("B6")
Set msg = Sheets("DETAILS").Range("B42")
msg.EntireRow.Hidden = True
With Sheets("DETAILS").Range("B6:B40")
.EntireRow.Hidden = False
End With
For Each cell In Sheets("DETAILS").Range("B6:B40")
Select Case cell.Value
Case 0
cell.EntireRow.Hidden = True
End Select
Next cell
If targ.EntireRow.Hidden = True Then
msg.EntireRow.Hidden = False
End If
Application.ScreenUpdating = True
End Sub
This is an example I contrived, I created this to explain the problem I'm having. Basically I want this code to run faster than it does. On a new sheet each loop of a cell starts fast, but if you let it run to near completion, and then run it again, it will hit 100ms per cell. In my sheet I have 16000 cells with a lot of comments like this, and they are manipulated individually every time the code runs. In this example they are obviously all the same, but in the real application each one is different.
Is there anyway to make this process faster?
Option Explicit
Public Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long
Public Sub BreakTheCommentSystem()
Dim i As Integer
Dim t As Long
Dim Cell As Range
Dim dR As Range
Set dR = Range(Cells(2, 1), Cells(4000, 8))
Dim rStr As String
rStr = "ABCDEFG HIJK LMNOP QRS TUV WX YZ" & Chr(10)
For i = 1 To 5
rStr = rStr & rStr
Next i
For Each Cell In dR
t = GetTickCount
With Cell
If .Comment Is Nothing Then
.AddComment
Else
With .Comment
With .Shape.TextFrame.Characters.Font
.Bold = True
.Name = "Arial"
.Size = 8
End With
.Shape.TextFrame.AutoSize = True
.Text rStr
End With
End If
End With
Debug.Print (GetTickCount - t & " ms ")
Next
rStr = Empty
i = Empty
t = Empty
Set Cell = Nothing
Set dR = Nothing
End Sub
Update 12-11-2015, I wanted this noted somewhere in case anyone runs into it, the reason I was trying to optimize this so much was because VSTO would not let me add a workbook file with all these comments. After 6 months of working with Microsoft, this is now a confirmed bug in the VSTO and Excel.
https://connect.microsoft.com/VisualStudio/feedback/details/1610713/vsto-hangs-while-editing-an-excel-macro-enabled-workbook-xlsm-file
According to the MSDN Comments collection and Comment object documentation, you can reference all comments within a worksheet through their indexed position and deal with them directly rather than cycle through each cell and determine whether it contains a comment.
Dim c As Long
With ActiveSheet '<- set this worksheet reference properly!
For c = 1 To .Comments.Count
With .Comments(c)
Debug.Print .Parent.Address(0, 0) ' the .parent is the cell containing the comment
' do stuff with the .Comment object
End With
Next c
End With
Also according to official docs for the Range.SpecialCells method you can easily determine a subset of cells in a worksheet using the xlCellTypeComments constant as the Type parameter.
Dim comcel As Range
With ActiveSheet '<- set this worksheet reference properly!
For Each comcel In .Cells.SpecialCells(xlCellTypeComments)
With comcel.Comment
Debug.Print .Parent.Address(0, 0) ' the .parent is the cell containing the comment
' do stuff with the .Comment object
End With
Next comcel
End With
I'm still unclear with the reasoning behind filling all non-commented cells with a blank comment but if you are trying to work with the comments only on a worksheet it is better to work with the subset of commented cells rather than cycling through all cells looking for a comment.
By turning off screen updating, I was able to reduce the time for each iteration from around 100ms to around 17ms. You can add the following to the start of the procedure:
Application.ScreenUpdating = False
You can turn updating back on at the end of the procedure by setting it back to true.
This code copies the data to a new worksheet, and recreates all notes:
In a new user module:
Option Explicit
Private Const MAX_C As Long = 4000
Private Const MAIN_WS As String = "Sheet1"
Private Const MAIN_RNG As String = "A2:H" & MAX_C
Private Const MAIN_CMT As String = "ABCDEFG HIJK LMNOP QRS TUV WX YZ"
Public Sub BreakTheCommentSystem_CopyPasteAndFormat()
Dim t As Double, wsName As String, oldUsedRng As Range
Dim oldWs As Worksheet, newWs As Worksheet, arr() As String
t = Timer
Set oldWs = Worksheets(MAIN_WS)
wsName = oldWs.Name
UpdateDisplay False
RemoveComments oldWs
MakeComments oldWs.Range(MAIN_RNG)
Set oldUsedRng = oldWs.UsedRange.Cells
Set newWs = Sheets.Add(After:=oldWs)
oldUsedRng.Copy
With newWs.Cells
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormulasAndNumberFormats
.Cells(1, 1).Copy
.Cells(1, 1).Select
End With
arr = GetCommentArrayFromSheet(oldWs)
RemoveSheet oldWs
CreateAndFormatComments newWs, arr
newWs.Name = wsName
UpdateDisplay True
InputBox "Duration: ", "Duration", Timer - t
'272.4296875 (4.5 min), 269.6796875, Excel 2007: 406.83203125 (6.8 min)
End Sub
.
Other functions:
Public Sub UpdateDisplay(ByVal state As Boolean)
With Application
.Visible = state
.ScreenUpdating = state
'.VBE.MainWindow.Visible = state
End With
End Sub
Public Sub RemoveSheet(ByRef ws As Worksheet)
With Application
.DisplayAlerts = False
ws.Delete
.DisplayAlerts = True
End With
End Sub
'---------------------------------------------------------------------------------------
Public Sub MakeComments(ByRef rng As Range)
Dim t As Double, i As Long, cel As Range, txt As String
txt = MAIN_CMT & Chr(10)
For i = 1 To 5
txt = txt & txt
Next
For Each cel In rng
With cel
If .Comment Is Nothing Then .AddComment txt
End With
Next
End Sub
Public Sub RemoveComments(ByRef ws As Worksheet)
Dim cmt As Comment
'For Each cmt In ws.Comments
' cmt.Delete
'Next
ws.UsedRange.ClearComments
End Sub
'---------------------------------------------------------------------------------------
Public Function GetCommentArrayFromSheet(ByRef ws As Worksheet) As String()
Dim arr() As String, max As Long, i As Long, cmt As Comment
If Not ws Is Nothing Then
max = ws.Comments.Count
If max > 0 Then
ReDim arr(1 To max, 1 To 2)
i = 1
For Each cmt In ws.Comments
With cmt
arr(i, 1) = .Parent.Address
arr(i, 2) = .Text
End With
i = i + 1
Next
End If
End If
GetCommentArrayFromSheet = arr
End Function
Public Sub CreateAndFormatComments(ByRef ws As Worksheet, ByRef commentArr() As String)
Dim i As Long, max As Long
max = UBound(commentArr)
If max > 0 Then
On Error GoTo restoreDisplay
For i = 1 To max
With ws.Range(commentArr(i, 1))
.AddComment commentArr(i, 2)
With .Comment.Shape.TextFrame
With .Characters.Font
If .Bold Then .Bold = False 'True
If .Name <> "Calibri" Then .Name = "Calibri" '"Arial"
If .Size <> 9 Then .Size = 9 '8
If .ColorIndex <> 9 Then .ColorIndex = 9
End With
If Not .AutoSize Then .AutoSize = True
End With
DoEvents
End With
Next
End If
Exit Sub
restoreDisplay:
UpdateDisplay True
Exit Sub
End Sub
Hope this helps
I think I found 2 ways to improve performance for your task
The code in your example runs for an average of 25 minutes, I got it down to 4.5 minutes:
Create a new sheet
Copy & paste all values from the initial sheet
Copy all comments to a 2 dimensional array (cell address & comment text)
Generates the same comments for the same cells on the new sheet, with the new format
This one is quite simple to implement and test, and is very specific to your case
From the description, you are processing the same comments over and over
The most expensive part is changing the font
With this adjustment it will only update the font for the new comments (existing ones are already using the font from previous processing, even if the text gets updated)
Try updating this part of the code in the actual file (it's not as effective for the example)
With .Shape.TextFrame
With .Characters.Font
If Not .Bold Then .Bold = True
If .Name <> "Arial" Then .Name = "Arial"
If .Size <> 8 Then .Size = 8
End With
If Not .AutoSize Then .AutoSize = True
End With
or:
With .Shape.TextFrame
With .Characters.Font
If Not .Bold Then
.Bold = True
.Name = "Arial"
.Size = 8
End If
End With
If Not .AutoSize Then .AutoSize = True
End With
Let me know if you're interested in the other option and I can provide the implementation
Turn off screen updating and if you not need to workboook to recalculate during the macro, setting the calculation to manual will really shave off some time. This will prevent every formula in your workbook for processing every time you alter a cell. These two functions allow me to crunch out rather large reports in a matter of seconds.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Of course, at the end of the macro, set them back to true and automatic
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
I am trying to make a code in Microsoft Excel Where it puts a text into a cell when another cell is filled in.
What I am looking for is that when cell A for example is filled cell C is filled in with OUT. Then when cell A is filled in again on the next line or another line below it cell C on the same line as cell A is filled in with IN.
We would like to utilize a barcode scanner for checking the tools in and out. I already figured out how to get the barcode to scan into column A
I would like this process to be repeated over and over again.
It's supposed to be a tracking sheet for when tools get taken out and get put back into stock. The text is going to constantly be added and nothing deleted. We want to utilize a barcode scanner to check tools in and out. The employees scan their barcode indicating them then they scan the tool indicating what tool they are taking. Then when they come back they scan their barcode again and then they scan the tool back into inventory. Of course just having this simple setup will lead to a mess of whether the tool is in or out and who used it last since we have a bunch of employees taking tools IN and OUT constantly. That way we can be sure of who used what tool last and whether it's IN or OUT.
Below I have the coding that I need for the time stamp.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim B As Range, AC As Range, t As Range
Set B = Range("B:B")
Set AC = Range("A:A")
Set t = Target
If Intersect(t, AC) Is Nothing Then Exit Sub
Application.EnableEvents = False
Range("B" & t.Row).Value = Now
Application.EnableEvents = True
End Sub
It sounds like a very contrived example for asking the question "In VBA, how do I fill an Excel cell with a specific string?"
The answer to that question is:
myRange.Value = "<myString>"
Anyway, this is how I would try to tackle your problem:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChange As Range
Dim rngIntersect As Range
Dim xlCell As Range
Dim inOut As String
Set rngChange = Range("A:A")
Set rngIntersect = Intersect(Target, rngChange)
If Not rngIntersect Is Nothing Then
Application.EnableEvents = False
For Each xlCell In rngIntersect
If xlCell.Value = "" Then
inOut = "OUT"
Else
inOut = "IN"
End If
xlCell.Offset(0, 1).Value = Now
xlCell.Offset(0, 2).Value = inOut
Next xlCell
Application.EnableEvents = True
End If
End Sub
Edit:
In response to the asker's comments, the following modified code should address the problem:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChange As Range
Dim rngIntersect As Range
Dim inOut As String
Set rngChange = Range("A:A")
Set rngIntersect = Intersect(Target, rngChange)
If Not rngIntersect Is Nothing Then
Application.EnableEvents = False
If rngIntersect.Row = 1 Then
inOut = "OUT"
ElseIf rngIntersect.Offset(-1, 2).Value = "OUT" Then
inOut = "IN"
Else
inOut = "OUT"
End If
rngIntersect.Offset(0, 1).Value = Now
rngIntersect.Offset(0, 2).Value = inOut
Application.EnableEvents = True
End If
End Sub
Edit2:
Use this to loop backwards through your log to determine the previous bookiung status for a specific id:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngChange As Range
Dim rngIntersect As Range
Dim xlCell As Range
Dim scanId As String
Dim inOutOld As String
Dim inOut As String
Set rngChange = Range("A:A")
Set rngIntersect = Intersect(Target, rngChange)
If Not rngIntersect Is Nothing Then
Application.EnableEvents = False
scanId = rngIntersect.Value
Set xlCell = rngIntersect
If rngIntersect.Row = 1 Then
inOut = "OUT"
Else
Do Until xlCell.Row = 1
Set xlCell = xlCell.Offset(-1, 0)
If xlCell.Value = scanId Then
inOutOld = xlCell.Offset(0, 2).Value
Exit Do
End If
Loop
End If
If inOutOld = "IN" Then
inOut = "OUT"
Else
inOut = "IN"
End If
rngIntersect.Offset(0, 1).Value = Now
rngIntersect.Offset(0, 2).Value = inOut
Application.EnableEvents = True
End If
End Sub
Instead of using VBA, you could do this with a worksheet 'IF()' formula.
=IF(A3="","","OUT")
=IF(A4="","","IN")
To break it down, this means that if cell A3 = nothing ("") then put nothing ("") in cell C3, but if there is something in cell A3, then put "OUT".
Place the first formula in cell C3 and the second one in C4. If the user of the tool inputs their initials/name in cell A3 then cell C3 will say OUT. It's not until the user comes back and returns the tool and enters their initials/name in cell A4 that cell C4 will say IN.
Hope this simple, non-VBA, example helps!
I cobbled together this a few years ago and now I need it tweaked slightly but I'm very rusty with VBA so could do with some advice:
Sub Colour_Cells_By_Criteria()
Dim myRange As Range
Dim myPattern As String
Dim myLen As Integer
Dim myCell As Range
Set myRange = Range("A1:A1000")
myPattern = "*1*"
myLen = 4
Application.ScreenUpdating = False
Application.StatusBar = "Macro running, please wait...."
For Each myCell In myRange
With myCell
If (.Value Like myPattern) And (Len(.Value) = myLen) Then
myCell.Interior.Color = 65535
myCell.Font.Bold = True
End If
End With
Next
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Rather than colouring and bolding any cells that are captured by the logic, I'd like to put the word "MATCH" in the same row in column B.
Any nudges in the right direction would be appreciated.
myCell.Offset(0,1).Value="Match"
Trying to loop through a range of cells and assigned a label to them based off of the text value in another cell. So if Cell J2 = "This Text" Then Cell A2 = "This Label"
As of now I keep getting a run time error number 424, stating object required
Private Function getPhase(ByVal cell As Range) As String
Select Case cell.Text
Case "Text1"
getPhase = "Label1"
Case "Text2"
getPhase = "Label2"
End Select
End Function
Sub setPhase()
Dim cycle As Range
Dim phase As Range
Set cycle = Range("J2:J10")
Set phase = Range("A2:A10")
For Each cell In phase.Cells
phase.Text = getPhase(cycle)
Next cell
End Sub
You have already got your answers :) Let me do some explaining in my post though :)
You cannot use this.
phase.Text = getPhase(cycle)
.Text is a Readonly property. i.e you cannot write to it but only read from it. You have to use .Value
Secondly you don't need to define the 2nd range if you are picking values from the same row. You can always us the .Offset property. See this
Option Explicit
Sub setPhase()
Dim rng As Range, phase As Range
Set phase = Sheets("Sheet1").Range("A2:A10")
For Each rng In phase
rng.Value = getPhase(rng.Offset(, 9))
Next
End Sub
Function getPhase(ByVal cl As Range) As String
Select Case cl.Value
Case "Text1"
getPhase = "Label1"
Case "Text2"
getPhase = "Label2"
End Select
End Function
Also there is nothing wrong with Select Case cell.Text since you are only reading from it. However, it is always good to use .Value. Reason being the .Value property returns the actual value of the cell where as .Text property returns the text which is displayed on the screen. The limit of Text is approx 8k characters in higher versions of Excel. The .Value on the other hand can store up to 32k characters.
I've changed the loop. This assumes that the two ranges are the same lengths
Function getPhase(ByVal cell As Range) As String
Select Case cell.Value
Case "Text1"
getPhase = "Label1"
Case "Text2"
getPhase = "Label2"
End Select
End Function
Sub setPhase()
Dim cycle As Range
Dim phase As Range
Set cycle = ThisWorkbook.Sheets("myexample").Range("J2:J10")
Set phase = ThisWorkbook.Sheets("myexample").Range("A2:A10")
Dim i As Integer
For i = 1 To phase.Cells.Count
phase.Cells(i).Value = getPhase(cycle.Cells(i))
Next i
End Sub
...or as siddharth had suggested use a formula.
Or do the formula via VBA:
Sub setPhase()
Dim phase As Range
Set phase = Excel.ThisWorkbook.Sheets("Sheet1").Range("A2:A10")
phase.Value = "=IF(J2=""Text1"",""Label1"",IF(J2=""Text2"",""Label2"",""""))"
End Sub
Here is my version:
Private Function getPhase(ByVal cell As Range) As String
Select Case cell.Text
Case "Text1"
getPhase = "Label1"
Case "Text2"
getPhase = "Label2"
End Select
End Function
Sub setPhase()
Dim cycle As Range
Dim phase As Range
Set cycle = ActiveSheet.Range("b2:b10")
Set phase = ActiveSheet.Range("A2:A10")
For Each cell In phase.Cells
cell.Value = getPhase(cycle.Cells(cell.Row, 1))
Next cell
End Sub