Mrrrr's Forum
Un forum care ofera solutii pentru unele probleme legate in general de PC. Pe langa solutii, aici puteti gasi si alte lucruri interesante // A forum that offers solutions to some PC related issues. Besides these, here you can find more interesting stuff.
Lista Forumurilor Pe Tematici
Mrrrr's Forum | Lista de useri | Cauta | Inregistrare | Login

POZE MRRRR'S FORUM

Nu sunteti logat.
Nou pe simpatie:
Giullia 01
Femeie
25 ani
Galati
cauta Barbat
25 - 60 ani
Mrrrr's Forum / Tutoriale si Ghiduri Utile // Tutorials and useful guides / [EXCEL] Resize and Relocate all Comments in Sheet or Workbook [VBA] Moderat de TonyTzu  
Autor
Mesaj Pagini: 1
TRaP
Membru activ

Inregistrat: acum 1 an
Postari: 384
Source & credits to Col Delane:
https://excel.uservoice.com/forums/3049 ... g-comments


Sub Resize_Relocate_CellComments()

' Purpose: Adjust size of all cell comment boxes on the active sheet of the active workbook to match the comment text therein, and locate it proximate to the host cell

'Define Procedure Variables
Dim wbk As Workbook
Dim wks As Worksheet
Dim cmt As Comment
Dim lArea As Long


On Error GoTo ErrorHandler

Set wbk = ActiveWorkbook
Set wks = ActiveSheet

Select Case MsgBox("Click:" & vbLf & vbLf & "YES to review & fix comments on ALL sheets in the Active WORKBOOK," & vbLf & vbLf & "NO to review & fix comments on the Active SHEET only, or" & vbLf & vbLf & "CANCEL to abort this process.", vbYesNoCancel Or vbQuestion Or vbDefaultButton2, "Cell Comments Resize and Relocation")

Case vbYes

For Each wks In wbk.Worksheets
Application.StatusBar = "Adjusting comments on " & wks.Name
For Each cmt In wks.Comments
With cmt
.Shape.TextFrame.AutoSize = True
If .Shape.Width > 300 Then
lArea = .Shape.Width * .Shape.Height
.Shape.Width = 200
.Shape.Height = (lArea / 200) * 1.1
End If
.Shape.Top = cmt.Parent.Top + 5
.Shape.Left = .Parent.Offset(0, 1).Left + 5
End With
Next cmt
Next wks

Case vbNo

Application.StatusBar = "Adjusting comments on " & wks.Name
For Each cmt In wks.Comments
With cmt
.Shape.TextFrame.AutoSize = True
If .Shape.Width > 300 Then
lArea = .Shape.Width * .Shape.Height
.Shape.Width = 200
.Shape.Height = WorksheetFunction.Min((lArea / 200) * 1.1, 100)
End If
.Shape.Top = cmt.Parent.Top + 5
.Shape.Left = .Parent.Offset(0, 1).Left + 5
End With
Next cmt

Case vbCancel
Exit Sub

End Select

Application.StatusBar = False
MsgBox "All cell comments resized and located proximate to their parent cell.", vbOKOnly, "Cell Comment Autosizing & Relocator"

ExitPoint: '---------------->>>>>>>>>-------------------->>>>>>>>>-------------------->>>>>>>>> Exit Sub
On Error GoTo 0
Exit Sub

ErrorHandler:
Resume ExitPoint

End Sub
'-----------------------------------------------------------


pus acum 11 zile
   
Pagini: 1    
Mergi la