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
Related
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 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.
I found this in this site, write it by Dan Donoghue
Sub BoldTags()
Dim X As Long, BoldOn As Boolean
BoldOn = False 'Default from start of cell is not to bold
For X = 1 To Len(ActiveCell.Text)
If UCase(Mid(ActiveCell.Text, X, 3)) = "<B>" Then
BoldOn = True
ActiveCell.Characters(X, 3).Delete
End If
If UCase(Mid(ActiveCell.Text, X, 4)) = "</B>" Then
BoldOn = False
ActiveCell.Characters(X, 4).Delete
End If
ActiveCell.Characters(X, 1).Font.Bold = BoldOn
Next
End Sub
I don't know anything about coding or magic or this.
This will do what you want:
Sub BoldTags()
Dim rng As Range, X As Long, BoldOn As Boolean
' This works on a selection of cells, if you want it on a full column comment out the next line and uncomment the one below.
For Each rng In Selection
'For Each rng In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
BoldOn = False 'Default from start of cell is not to bold
For X = 1 To Len(rng.Text)
If UCase(Mid(rng.Text, X, 3)) = "<B>" Then
BoldOn = True
rng.Characters(X, 3).Delete
End If
If UCase(Mid(rng.Text, X, 4)) = "</B>" Then
BoldOn = False
rng.Characters(X, 4).Delete
End If
rng.Characters(X, 1).Font.Bold = BoldOn
Next
Next
End Sub
Just loop over the cells in the activecell's column:
Sub BoldTags(r As Range)
Dim X As Long, BoldOn As Boolean
BoldOn = False 'Default from start of cell is not to bold
For X = 1 To Len(r.Text)
If UCase(Mid(r.Text, X, 3)) = "<B>" Then
BoldOn = True
r.Characters(X, 3).Delete
End If
If UCase(Mid(r.Text, X, 4)) = "</B>" Then
BoldOn = False
r.Characters(X, 4).Delete
End If
r.Characters(X, 1).Font.Bold = BoldOn
Next
End Sub
Sub dural()
Dim rng As Range, r As Range
Set rng = Intersect(ActiveCell.EntireColumn, ActiveSheet.UsedRange)
For Each r In rng
Call BoldTags(r)
Next r
End Sub
NOTE:
The Call is not really necessary
Make sure the list does not contain empties.
I found code in a book:
Option Explicit
Sub SaveAndCLose()
Application.DisplayAlerts = False
Tabelle1.Range("A1").Value = _
"Last Edition " & Now & " from User " & Environ("Username")
ThisWorkbook.Close Savechanges:=True
Application.DisplayAlerts = True
End Sub
Is it possible to document the last 10 edits. For example: today USER X edited - Range("A1"). Next day there was another edit made Range("A2") and so on for each edition for that file.
I know that in Excel Audit Trail isn't implemented but that simple code gives information who made the last edit.
Or maybe there is a better way to implement an Audit Trail for Excel files?
A straightforward simple code might be the following code
Option Explicit
Const X = "X"
Sub SaveAndClose()
Dim rgB As Range
Dim rowX As Long
Dim auditTxt As String
Set rgB = Tabelle1.Range("B1:B10")
auditTxt = "Last Edition " & Now & " from User " & Environ("Username")
rowX = findXA(rgB)
'rowX = findX(rgB)
If rowX = 0 Then
Tabelle1.Cells(1, 1).Value = auditTxt
Tabelle1.Cells(1, 2).Value = X
ElseIf rowX = 10 Then
Tabelle1.Cells(1, 1).Value = auditTxt
Tabelle1.Cells(1, 2).Value = X
Tabelle1.Cells(rowX, 2).ClearContents
Else
Tabelle1.Cells(rowX + 1, 1).Value = auditTxt
Tabelle1.Cells(rowX + 1, 2).Value = X
Tabelle1.Cells(rowX, 2).ClearContents
End If
'' I commented this part of the code for testing purposes
'' Uncomment to save and close the file
' Application.DisplayAlerts = False
' ThisWorkbook.Close Savechanges:=True
' Application.DisplayAlerts = True
End Sub
Function findX(rg As Range) As Long
' find the X by putting the range into an array and looping through it
Dim vDat As Variant
Dim i As Long
findX = 0
vDat = WorksheetFunction.Transpose(rg)
For i = LBound(vDat) To UBound(vDat)
If UCase(vDat(i)) = X Then
findX = i
Exit Function
End If
Next
End Function
Function findXA(rg As Range) As Long
' find the X by usind ragne.find
Dim rgX As Range
Set rgX = rg.Find(X, , , , , , False)
If rgX Is Nothing Then
findXA = 0
Else
findXA = rgX.Row
End If
End Function
Code uses col A and B and it put an X into col B for the last written line. Maybe it is not a "clever" code but IMO it is just easy to follow, I hope
I need to apply bold to all cells within a certain range where the formula result is 10 or more. I've tried the following code but it seems to apply bold randomly!
Sub BoldHighHours()
Application.ScreenUpdating = False
Dim c As Object
For Each c In Range("I7:AM1005")
If c.Value >= 10 Then
c.Offset(0, 1).Font.Bold = True
c.Offset(0, 2).Font.Bold = True
Else
c.Offset(0, 1).Font.Bold = False
c.Offset(0, 2).Font.Bold = False
End If
Next
Application.ScreenUpdating = True
End Sub
If you've been following my previous questions/saga you'll understand why I can't use conditional formatting! Autofilter doth not look kindly upon large amounts of conditional formatting and punishes ye with slowdown greatly!
You need to remove the Offset():
Sub BoldHighHours()
Application.ScreenUpdating = False
Dim c As Range
For Each c In Range("I7:AM1005")
If c.Value >= 10 Then
c.Font.Bold = True
Else
c.Font.Bold = False
End If
Next
Application.ScreenUpdating = True
End Sub
my optimisation:
Sub BoldHighHours()
Application.ScreenUpdating = False
Dim c As Long
For Each c = 9 to 39 ' hopefully i to am..
ActiveSheet.AutoFilterMode = False
With Range("A8:A1005").Offset(0, c - 1)
.Font.Bold = False
.AutoFilter Field:=1, Criteria1:=">=10"
.Font.Bold = True
End With
Next
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub