variable - Acelerar el trabajo con comentarios en Excel VBA
refrescar hoja excel vba (5)
Este es un ejemplo que ideé, lo creé para explicar el problema que estoy teniendo. Básicamente, quiero que este código se ejecute más rápido de lo que lo hace. En una hoja nueva, cada ciclo de una celda comienza rápido, pero si lo deja casi al final y luego lo vuelve a ejecutar, alcanzará los 100 ms por celda. En mi hoja tengo 16000 celdas con muchos comentarios como este, y se manipulan de forma individual cada vez que se ejecuta el código. En este ejemplo, obviamente son todos iguales, pero en la aplicación real cada uno es diferente.
¿Hay alguna forma de hacer este proceso más rápido?
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
Actualización 12-11-2015, quería que esto se anotara en algún lugar en caso de que alguien se topara con él, la razón por la que intentaba optimizar esto era porque VSTO no me dejaba agregar un archivo de libro de trabajo con todos estos comentarios. Después de 6 meses de trabajar con Microsoft, ahora se trata de un error confirmado en VSTO y Excel.
Al desactivar la actualización de la pantalla, pude reducir el tiempo de cada iteración de alrededor de 100 ms a alrededor de 17 ms. Puede agregar lo siguiente al comienzo del procedimiento:
Application.ScreenUpdating = False
Puede volver a activar la actualización al final del procedimiento volviendo a establecerla en verdadero.
Creo que encontré 2 formas de mejorar el rendimiento de tu tarea
El código en su ejemplo se ejecuta durante un promedio de 25 minutos, lo bajé a 4.5 minutos:
- Crea una nueva hoja
- Copie y pegue todos los valores de la hoja inicial
- Copie todos los comentarios en una matriz bidimensional (dirección de la celda y texto de comentario)
- Genera los mismos comentarios para las mismas celdas en la nueva hoja, con el nuevo formato
Este es bastante simple de implementar y probar, y es muy específico para su caso
- A partir de la descripción, está procesando los mismos comentarios una y otra vez
- La parte más cara es cambiar la fuente
- Con este ajuste, solo actualizará la fuente para los nuevos comentarios (los existentes ya están usando la fuente del procesamiento anterior, incluso si el texto se actualiza)
Intente actualizar esta parte del código en el archivo real (no es tan efectivo para el ejemplo)
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
o:
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
Avíseme si está interesado en la otra opción y puedo proporcionar la implementación
Desactive la actualización de la pantalla y, si no necesita workboook para volver a calcular durante la macro, ajustar el cálculo a manual realmente reducirá el tiempo. Esto evitará que todas las fórmulas de su libro de trabajo se procesen cada vez que modifique una celda. Estas dos funciones me permiten contrastar informes bastante grandes en cuestión de segundos.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Por supuesto, al final de la macro, configúrelos nuevamente como verdaderos y automáticos
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Este código copia los datos en una nueva hoja de cálculo y recrea todas las notas:
En un nuevo módulo de usuario:
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
.
Otras funciones:
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
Espero que esto ayude
Según la recopilación de comentarios de MSDN y la documentación del objeto Comentario , puede hacer referencia a todos los comentarios dentro de una hoja de cálculo a través de su posición indexada y tratarlos directamente en lugar de recorrer cada celda y determinar si contiene un comentario.
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
También de acuerdo con los documentos oficiales para el método Range.SpecialCells , puede determinar fácilmente un subconjunto de celdas en una hoja de cálculo utilizando la constante xlCellTypeComments como el parámetro Tipo .
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
Todavía no tengo claro el razonamiento detrás de llenar todas las celdas no comentadas con un comentario en blanco, pero si intenta trabajar con los comentarios solo en una hoja de trabajo, es mejor trabajar con el subconjunto de celdas comentadas en lugar de recorrer todas las celdas buscando un comentario.