I need your help! I've read many many forum and tread, but unfortunately I don't find a solution.
I'll need to build a macro that working on excel for Mac that pick an image from url and insert in a comment.
Thanks in advance
Here is a macro that working well on windows, but not in Mac osx.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngToCheck As Range
Dim n As Integer
Dim pic_file As String
Dim pict1 As Picture
n = Cells(Rows.Count, 1).End(xlUp).Row
If n = 0 Then Exit Sub
Set rngToCheck = Range(Cells(1, 2), Cells(n + 1, 2))
On Error Resume Next
If Intersect(ActiveCell, rngToCheck) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
ActiveCell.Comment.Delete
' pic_file = "http://xxx.xxx.com" & CStr(Cells(ActiveCell.Row, 1).Value) & ".jpg"
pic_file = "http://xxx.xxx.com" & CStr(Cells(ActiveCell.Row, 1).Value) & ".jpg"
Set pict1 = ActiveSheet.Pictures.Insert(pic_file)
If Not pict1 Is Nothing Then On Error Resume Next
If ActiveCell.Comment Is Nothing Then ActiveCell.AddComment
With ActiveCell.Comment.Shape
.Fill.Visible = msoTrue
.Fill.UserPicture (pic_file)
If (pict1.Width < pict1.Height) Then
.Height = 200
.Width = pict1.Width / pict1.Height * 200
Else
.Width = 200
.Height = pict1.Height / pict1.Width * 200
End If
End With
ActiveCell.Comment.Visible = False
'ActiveSheet.Shapes.SelectAll
pict1.Delete
'Selection.Delete
Application.CutCopyMode = False
Application.EnableEvents = True
' End If
End If
End Sub
In widows all works fine, in Mac I've only the empty yellow comment boxes.
Related
I am trying to get rid of the horizontal scroll bar in my listbox--which appears when a user clicks in certain cells and is then consequently "deleted" each time the user clicks out of that cell (so I can't change it manually, I must change it with code)--but the .ColumnWidths property does not seem to function.
It seems the ColumnWidths is default set at 74--this based on the fact that if I set my Width at 74 or greater there is no horizontal scroll bar.
If when clicking a cell, I go into design mode, open properties, I can manually set the ColumnWidths to 35. That is not a solution since my listbox is created and deleted depending on the user's active cell. Nonetheless this confirmed that it is something about how my code is written.
Option Explicit
Private WithEvents Lbx As MSForms.ListBox
Private oTarget As Range
Private ListBoxName As String
Private Const Cell_A1 As String = "B1:B20" 'change addr as required.
Private Sub Lbx_Change()
Dim k As Long
oTarget.ClearContents
For k = 0 To Lbx.ListCount - 1
If Lbx.Selected(k) Then
If Len(oTarget) = 0 Then
oTarget = Lbx.List(k)
Else
oTarget = _
Trim(oTarget & vbNewLine & Lbx.List(k))
End If
End If
Next
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim oListBox As OLEObject
On Error Resume Next
Me.OLEObjects(1).Delete
Range(Cell_A1).Interior.ColorIndex = 0
If Target.Column = 2 And (Target.Row >= 1 And Target.Row <= 20) Then
'UCase(Target.Address(0, 0)) = UCase(Cell_A1)
Application.DisplayFormulaBar = False
Set oListBox = _
Me.OLEObjects.Add(ClassType:="Forms.ListBox.1")
With oListBox
Names.Add "ListBoxName", .Name
.Left = Target.Offset(0,1).Left
.Top = Target.Offset(0, 0).Top
.ColumnCount = 1
.ColumnWidths = "35"
.Width = 54
.Height = Me.StandardHeight * 16
.Object.ListStyle = fmListStylePlain
.ListFillRange = "A1:A20"
.Placement = xlFreeFloating
.Object.MultiSelect = fmMultiSelectMulti
.Object.SpecialEffect = fmSpecialEffectFlat
.Object.BorderStyle = fmBorderStyleSingle
With Application
.OnTime Now + _
TimeSerial(0, 0, 0.01), Me.CodeName & ".Hooklistbox"
.CommandBars.FindControl(ID:=1605).Execute
End With
End With
Else
Application.DisplayFormulaBar = True
Names("ListBoxName").Delete
Range(Cell_A1).Interior.ColorIndex = 0
End If
End Sub
Private Sub Hooklistbox()
Application.CommandBars.FindControl(ID:=1605).Reset
Set oTarget = ActiveCell
ActiveCell.Interior.Color = vbGreen
'display the listbox and hook it.
With Me.OLEObjects(Evaluate("ListBoxName"))
.Visible = True
Set Lbx = .Object
End With
End Sub
Type
.Object.
Before .ColumnCount and .ColumnWidths
And get rid of the on error resume next, which brought you to this "hidden" error in the first place
Use a on error goto 0 afterwards when it's not needed anymore
++
instead of:
On Error Resume Next
Me.OLEObjects(1).Delete
you could use:
If Me.OLEObjects.Count > 0 Then Me.OLEObjects(1).Delete
and delete this line (because Names will be overwritten, so no need to delete:
Names("ListBoxName").Delete
I have been using this code which works for some URL but not for all I really do not why. Then I have tried with different available codes online but no success.
Your help will be really appreciated in this regards.
Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub URLPictureInsert()
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("A1:A3000") ' <---- ADJUST THIS
For Each cell In rng
Filename = cell
If InStr(UCase(Filename), "JPG") > 0 Then ' <--- USES JPG ONLY
ActiveSheet.Pictures.Insert(Filename).Select
Set theShape = Selection.ShapeRange.Item(1)
If theShape Is Nothing Then GoTo isnill
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With theShape
.LockAspectRatio = msoFalse
.Width = 20
.Height = 20
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
isnill:
Set theShape = Nothing
Range("A2").Select
End If
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub
URL's
https://s3-eu-west-1.amazonaws.com/images.linnlive.com/a93f20bbb3640a1a7dc9b9a05bee8540/fc310885-cd82-49cb-bc7a-aabd08531517.jpg
https://s3-eu-west-1.amazonaws.com/images.linnlive.com/a93f20bbb3640a1a7dc9b9a05bee8540/c6c7a645-8273-40ee-87e5-1dd385111a28.jpg
https://s3-eu-west-1.amazonaws.com/images.linnlive.com/a93f20bbb3640a1a7dc9b9a05bee8540/cf9f971b-6af6-4894-a2d5-c58681adb466.jpg
Try this code below, it will Debug.Print the URL that fails to insert. Adapt to your need (if any)
Sub URLPictureInsert()
Dim rng As Range
Dim cell As Range
Application.ScreenUpdating = False
With ActiveSheet
Set rng = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row) ' <---- ADJUST THIS
End With
For Each cell In rng
If InStr(UCase(cell), "JPG") > 0 Then '<--- ONLY USES JPG'S
With cell.Offset(0, 1)
On Error Resume Next
ActiveSheet.Shapes.AddPicture cell, msoFalse, msoTrue, .Left + (.Width - 10) / 2, .Top + (.Height - 10) / 2, 20, 20
If Err.Number = 1004 Then Debug.Print "File not found: " & cell
On Error GoTo 0
End With
End If
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub
You will need to use On Error Resume Next, but only for the single statement that inserts the picture. And you should get rid of the Select. The Pictures.Insert-method returns the reference to the inserted image, assign this to a variable and work with that.
Additionally, I would suggest to split your code and create a routine that insert one image into a cell. Call this routine from the loop. I have implemented it as a function that returns True if it was successfull, it's up to you to decide if you want to do something if it returns False.
Function TryInsertImg(filename As String, cell As Range) As Boolean
Dim p As Picture
On Error Resume Next
Set p = cell.Parent.Pictures.Insert(filename)
If Err.Number > 0 Then Debug.Print "Couldn't insert image " & Err.Number & "-" & Err.Description
On Error GoTo 0
If p Is Nothing Then
Exit Function
End If
Dim theShape As Shape
Set theShape = p.ShapeRange.Item(1)
With theShape
.LockAspectRatio = msoFalse
.Width = 20
.Height = 20
.Top = cell.Top + (cell.Height - .Height) / 2
.Left = cell.Left + (cell.Width - .Width) / 2
End With
TryInsertImg = True
End Function
Your calling routine could look like this:
For Each cell In rng
Filename = cell
If InStr(UCase(Filename), "JPG") > 0 Then '<--- ONLY USES JPG'S
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
If Not TryInsertImg(filename, xRg) then
xRg = "(error loading image)"
End If
End If
Next cell
I have a column in a table that will contain entire phrases with difficult words ("hypothetical exemplification of those akiophrastic words"). I have a list of most words that I expect will be used there.
I found a great solution here but it doesn't quite match my usecase. It works if you want to choose the content of your cell from a list of choices. I want to be able to get suggestions for the currently-typed word within the cell. So I write "hypoth" and click "hypothetical" from the dropdown, then I hit spacebar and start writing "exem" and want to get suggestions for that as well, and so on.
I will try changing the VBA code provided in my hyperlink above but I'm not sure I'll be successful. I'm open to any suggestion. It can also involve userforms although I doubt there is a way using them.
EDIT: On request, I'm summarizing the linked tutorial and posting its code.
It makes you create a Combo Box from the developer tools tab and name it TempCombo.
In the code for the worksheet, where the box is located, you write the following code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2020/01/16
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim xArr
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
If .ListFillRange = "" Then
xArr = Split(xStr, ",")
Me.TempCombo.List = xArr
End If
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
Here's a very basic example using a text box (txt1) and a listbox (lstMatches) on a worksheet:
Option Explicit
Dim suspend As Boolean
Private Sub lstMatches_Click()
Dim word, pos As Long
word = Me.lstMatches.Value
suspend = True
'try to replace the last "word" (or part of word) with the selected word
pos = InStrRev(Me.txt1.Text, " ")
If pos > 0 Then
Me.txt1.Text = Left(Me.txt1.Text, pos) & " " & word
Else
Me.txt1.Text = word
End If
Me.txt1.Activate
suspend = False
End Sub
Private Sub txt1_Change()
Dim txt As String, arr, last As String, allWords, r As Long
If suspend Then Exit Sub 'don't respond to programmatic changes
txt = Trim(Me.txt1.Text)
If Len(txt) = 0 Then 'is there any text?
Me.lstMatches.Clear
Exit Sub
End If
arr = Split(txt, " ")
last = arr(UBound(arr)) 'get the last word
If Len(last) > 1 Then
allWords = Me.Range("words").Value 'get the words list
Me.lstMatches.Clear
For r = 1 To UBound(allWords)
If allWords(r, 1) Like last & "*" Then 'match on "starts with"
Me.lstMatches.AddItem allWords(r, 1)
End If
Next r
End If
End Sub
Using the linked code from my OP and Tim Williams's excellent code, this is the result I got to. To use this, you will have to adapt some lines. There were some really odd bugs which I fixed by adapting some parts. Also added control functionality with Return (+Shift), up and down keys.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim xText As OLEObject
Dim xStr As String
Dim xList As OLEObject
Dim xWs As Worksheet
Dim xArr
Dim ListTarget As Range
' Suggestion box placement
Set ListTarget = Target.Offset(2, 1)
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xText = xWs.OLEObjects("txt1")
Set xList = xWs.OLEObjects("lstMatches")
' Every click lets the boxes disappear.
With xText
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
With xList
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
' Restrict where you want this functionality in your sheet here
If Target.Validation.Type = 3 And Target.column = 10 And Target.row > 4 Then
Target.Validation.InCellDropdown = False
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xText
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 200 ' Size of text box
.Height = Target.Height + 5 ' Make it a little taller for better readability
.ListFillRange = ""
'If .ListFillRange = "" Then
'xArr = Split(xStr, ",")
'Me.TempCombo.list = xArr
'End If
.LinkedCell = Target.Address
End With
With xList
.Visible = True
.Left = ListTarget.Left
.Top = ListTarget.Top
.Width = ListTarget.Width + 200 ' Size of suggestions box
.Height = ListTarget.Height + 100
If .ListFillRange = "" Then 'This loop fills the suggestions with the list from the validation formula, unless already changed by input
xArr = Split(xStr, ",")
xList.ListFillRange = xArr
End If
End With
xText.Activate
Me.lstMatches.Locked = False ' It randomly locked for me, just in case.
' The following two lines fix an obscure bug that made the suggestions un-clickable at random.
ActiveWindow.SmallScroll ToLeft:=1
ActiveWindow.SmallScroll ToRight:=1
End If
End Sub
Private Sub lstMatches_Click()
Dim word, pos As Long
word = Me.lstMatches.value
suspend = True ' disables the text change function for programmatic changes
'try to replace the last "word" (or part of word) with the selected word
pos = InStrRev(Me.txt1.text, " ")
If pos > 0 Then
Me.txt1.text = Left(Me.txt1.text, pos) & word
Else
Me.txt1.text = word
End If
Me.txt1.Activate
suspend = False
End Sub
Private Sub txt1_Change()
Dim txt As String, arr, last As String, allWords, r As Long
Dim data_lastRow As Long
data_lastRow = Worksheets("my_data").Cells(2, 5).End(xlDown).row
If suspend Then Exit Sub 'don't respond to programmatic changes
txt = Trim(Me.txt1.text)
If Len(txt) = 0 Then
Me.lstMatches.Clear
Exit Sub
End If
arr = Split(txt, " ")
last = arr(UBound(arr))
If Len(last) > 1 Then
allWords = Worksheets("my_data").Range("E2:E" & CStr(data_lastRow)).value 'get the words list
Me.lstMatches.Clear
For r = 1 To UBound(allWords)
If allWords(r, 1) Like last & "*" Then 'match on "starts with"
Me.lstMatches.AddItem allWords(r, 1)
If Me.lstMatches.ListCount = 15 Then Exit Sub ' limiting it to 15 suggestions
End If
Next r
End If
End Sub
Private Sub txt1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 13
If Shift = 0 Then
Application.ActiveCell.Offset(1, 0).Activate
Else
Application.ActiveCell.Offset(-1, 0).Activate
End If
Case vbKeyDown
Application.ActiveCell.Offset(1, 0).Activate
Case vbKeyUp
Application.ActiveCell.Offset(-1, 0).Activate
Case vbKeyLeft
Application.ActiveCell.Offset(0, -1).Activate
End Select
End Sub
I'm currently implementing some VBA code that allows a listbox to trigger on certain columns and then once filled in the cell gets filled with the selection. The initial solution has been adapted from Checkboxes for multiple values in a single cell in Excel except instead of triggering on a specific cell I want it triggered for specific cells within an entire column. I've managed to adapt this code just fine and the boxes fill in, but they only update if the next selected cell is outside that entire column (as they still fall within the intersect otherwise). Is there a way to allow intersect to account for any cell selection change? I just want the content to fill in regardless of whether I select a cell on a different column (which works) or a different row (which doesn't). I've put the code in here but it's a broad copy of the linked code above.
Thanks in advance!
Option Explicit
Dim fillRng As Range
Dim fillRngp As Range
Dim fillRngr As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim LBColors As MSForms.ListBox
Dim LBPers As MSForms.ListBox
Dim LBRec As MSForms.ListBox
Dim LBobj As OLEObject
Dim LBoba As OLEObject
Dim LBObr As OLEObject
Dim i As Long
Set LBobj = Me.OLEObjects("LB_Process")
Set LBColors = LBobj.Object
Set LBoba = Me.OLEObjects("LB_Personal")
Set LBPers = LBoba.Object
Set LBObr = Me.OLEObjects("LB_Record")
Set LBRec = LBObr.Object
If Selection.Count > 1 Then
Else
If Not Intersect(Target, Range("G5:G10000")) Is Nothing Then
Set fillRng = Target
With LBColors
.Left = fillRng.Offset(0, 1).Left
.Top = fillRng.Offset(0, 1).Top
.Width = fillRng.Offset(0, 1).Width
.Visible = True
End With
Else
LBobj.Visible = False
If Not fillRng Is Nothing Then
fillRng.ClearContents
With LBColors
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRng.Value = "" Then
If .Selected(i) Then fillRng.Value = .List(i)
Else
If .Selected(i) Then fillRng.Value = _
fillRng.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRng = Nothing
Set fillRngp = Nothing
Set fillRngr = Nothing
End If
End If
If Not Intersect(Target, Range("M5:M10000")) Is Nothing Then
Set fillRngp = Target
With LBPers
.Left = fillRngp.Offset(0, 1).Left
.Top = fillRngp.Offset(0, 1).Top
.Width = fillRngp.Offset(0, 1).Width
.Visible = True
End With
Else
LBoba.Visible = False
If Not fillRngp Is Nothing Then
fillRngp.ClearContents
With LBPers
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRngp.Value = "" Then
If .Selected(i) Then fillRngp.Value = .List(i)
Else
If .Selected(i) Then fillRngp.Value = _
fillRngp.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRngp = Nothing
Set fillRng = Nothing
Set fillRngr = Nothing
End If
End If
If Not Intersect(Target, Range("O5:O10000")) Is Nothing Then
Set fillRngr = Target
With LBRec
.Left = fillRngr.Offset(0, 1).Left
.Top = fillRngr.Offset(0, 1).Top
.Width = fillRngr.Offset(0, 1).Width
.Visible = True
End With
Else
LBRec.Visible = False
If Not fillRngr Is Nothing Then
fillRngr.ClearContents
With LBRec
If .ListCount <> 0 Then
For i = 0 To .ListCount - 1
If fillRngr.Value = "" Then
If .Selected(i) Then fillRngr.Value = .List(i)
Else
If .Selected(i) Then fillRngr.Value = _
fillRngr.Value & ", " & .List(i)
End If
Next
End If
For i = 0 To .ListCount - 1
.Selected(i) = False
Next
End With
Set fillRng = Nothing
Set fillRngp = Nothing
Set fillRngr = Nothing
End If
End If
End If
End Sub
Try this - there's a lot of repetition in your posted version which can be factored away since all three listboxes get used the same way.
I also added in a method to synchronize the listbox with any existing data already in the cell.
Option Explicit
Dim fillRng As Range 'any previously-selected cell
Dim theOLE As OLEObject 'any visible listbox container
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim theLB As MSForms.ListBox
'any list visible ?
If Not theOLE Is Nothing Then
'clean up after previous list editing
Set theLB = theOLE.Object 'from the global
fillRng.Value = LBSelectedItems(theLB) 'comma-separated list of selections
theOLE.Visible = False
Set theOLE = Nothing 'clear globals
Set fillRng = Nothing
End If
'need to exit now?
If Target.Count <> 1 Then Exit Sub
If Target.Row < 5 Or Target.Row > 10000 Then Exit Sub
'which column are we dealing with
Select Case Target.Column
Case 7: Set theOLE = Me.OLEObjects("LB_Process")
Case 13: Set theOLE = Me.OLEObjects("LB_Personal")
Case 15: Set theOLE = Me.OLEObjects("LB_Record")
Case Else: Exit Sub '<< nothing else to do here
End Select
Set fillRng = Target ' populate globals
Set theLB = theOLE.Object
SetList fillRng, theLB ' any cell value to sync with the list?
With theLB
.Left = fillRng.Offset(0, 1).Left
.Top = fillRng.Offset(0, 1).Top
.Width = fillRng.Offset(0, 1).Width
.Visible = True
End With
End Sub
'select list items, based on any existing value in the cell
Sub SetList(rng As Range, LB As MSForms.ListBox)
Dim arr, i As Long
If Len(rng.Value) = 0 Then Exit Sub 'nothing to do...
arr = Split(rng.Value, ",") 'existing choices are comma-delimited
For i = 0 To LB.ListCount - 1
'?list item matches value from cell?
If Not IsError(Application.Match(LB.List(i), arr, 0)) Then
LB.Selected(i) = True
End If
Next i
End Sub
'return a comma-delimted list of selected items from a listbox
Function LBSelectedItems(LB As MSForms.ListBox)
Dim i As Long, lst, sep
For i = 0 To LB.ListCount - 1
If LB.Selected(i) Then
lst = lst & sep & LB.List(i)
sep = "," 'at least one selection, so need a separator
LB.Selected(i) = False 'deselect after checking
End If
Next i
LBSelectedItems = lst
End Function
How can I display the copied comment FONT the same as original comment (e.g still wants part of the comment bold and underlined)?
Sub Comments()
Dim X As Long, RngName As String, curwks As Worksheet
Sheet1.Select
Set curwks = ActiveSheet
If curwks.Comments.Count Then
Sheet2.Select
Range("A1").Select
On Error Resume Next
For X = 1 To curwks.Comments.Count
With curwks.Comments.Item(X)
Sheet2.Range("A1").Offset(X, 0).Resize(1, 1) = _
Array(.Text)
End With
Next
End If
End Sub
This is not a full solution because the Underline portion doesn't work for some reason, possibly a bug. If I get a chance I'll look into it, but something might be better than nothing.
Sub Comments()
Dim X As Long, i As Long
If Sheet1.Comments.Count Then
For X = 1 To Sheet1.Comments.Count
With Sheet2.Range("A1").Offset(X, 0)
.Clear
.Font.Bold = False
.Font.Underline = False
.Value = Sheet1.Comments.Item(X).Text
End With
With Sheet1.Comments.Item(X).Shape.TextFrame
For i = 1 To .Characters.Count
If .Characters(i, 1).Font.Bold = True Then
Sheet2.Range("A1").Offset(X, 0).Characters(i, 1).Font.Bold = True
End If
If .Characters(i, 1).Font.Underline = True Then
Sheet2.Range("A1").Offset(X, 0).Characters(i, 1).Font.Underline = True
End If
Next i
End With
Next
End If
End Sub