Estoy usando VBA para Excel. Tengo un código que hace lo siguiente:

  • Tome una matriz de palabras (llamada Search_Terms)

  • Luego tengo una función (ver más abajo) que recibe el Search_Terms y una referencia a una celda en Excel.

  • Luego, la función busca el texto dentro de la celda.

  • Encuentra todas las subcadenas que coinciden con las palabras en Search_Terms dentro de la celda y cambia su formato.

  • La función que se muestra a continuación ya funciona .

  • Sin embargo, es bastante lento cuando quiero buscar varios miles de celdas con una matriz de 20 o 30 palabras.

  • Me pregunto si hay una forma más eficiente / idiomática de hacer esto (no estoy muy familiarizado con VBA y solo estoy hackeando mi camino).

¡Gracias!

Dim Search_Terms As Variant
Dim starting_numbers() As Integer ' this is an "array?" that holds the starting position of each matching substring
Dim length_numbers() As Integer 'This is an "array" that holds the length of each matching substring

Search_Terms = Array("word1", "word2", "word3") 

Call change_all_matches(Search_Terms, c) ' "c" is a reference to a Cell in a Worksheet

Function change_all_matches(terms As Variant, ByRef c As Variant)
    ReDim starting_numbers(1 To 1) As Integer ' reset the array
    ReDim length_numbers(1 To 1) As Integer ' reset the array

    response = c.Value 

    ' This For-Loop Searches through the Text in the Cell and finds the starting position & length of each matching substring
    For Each term In terms ' Iterate through each term
        Start = 1
        Do
            pos = InStr(Start, response, term, vbTextCompare) 'See if we have a match
            If pos > 0 Then
                Start = pos + 1 ' keep looking for more substrings
                starting_numbers(UBound(starting_numbers)) = pos
                ReDim Preserve starting_numbers(1 To UBound(starting_numbers) + 1) As Integer  ' Add each matching "starting position" to our array called "starting_numbers"
                length_numbers(UBound(length_numbers)) = Len(term)
                ReDim Preserve length_numbers(1 To UBound(length_numbers) + 1) As Integer
            End If
        Loop While pos > 0  ' Keep searching until we find no substring matches
    Next


    c.Select 'Select the cell
    ' This For-Loop iterates through the starting position of each substring and modifies the formatting of all matches
    For i = 1 To UBound(starting_numbers)
        If starting_numbers(i) > 0 Then
                With ActiveCell.Characters(Start:=starting_numbers(i), Length:=length_numbers(i)).Font
                    .FontStyle = "Bold"
                    .Color = -4165632
                    .Size = 13
                End With
            End If
     Next i
     Erase starting_numbers
    Erase length_numbers
End Function
1
pdanese 16 sep. 2017 a las 01:36

2 respuestas

La mejor respuesta

El siguiente código puede ser un poco más rápido (no lo he medido)

Lo que hace:

  • Desactiva las funciones de Excel, como sugiere @Ron (ScreenUpdating, EnableEvents, Calculation)
  • Establece el rango utilizado y captura la última columna utilizada
  • Repite cada columna y aplica un autofiltro para cada una de las palabras.
  • Si hay más de una fila visible (la primera es el encabezado)
    • Repite todas las celdas visibles en la columna actualmente filtrada automáticamente
    • Verifica que la celda no contenga errores y no esté vacía (este orden, verificaciones distintas)
    • Cuando encuentra la palabra de filtro actual, realiza los cambios
    • Pasa a la siguiente celda, luego a la siguiente palabra de filtro hasta que todas las palabras de búsqueda estén listas
    • Pasa a la siguiente columna, repite el proceso anterior
  • Borra todos los filtros y vuelve a activar las funciones de Excel

Option Explicit

Const ALL_WORDS = "word1,word2,word3"

Public Sub ShowMatches()
    Dim ws As Worksheet, ur As Range, lc As Long, wrdArr As Variant, t As Double

    t = Timer
    Set ws = Sheet1
    Set ur = ws.UsedRange
    lc = ur.Columns.Count
    wrdArr = Split(ALL_WORDS, ",")
    enableXL False

    Dim c As Long, w As Long, cVal As String, sz As Long, wb As String
    Dim pos As Long, vr As Range, cel As Range, wrd As String

    For c = 1 To lc
        For w = 0 To UBound(wrdArr)
            If ws.AutoFilterMode Then ur.AutoFilter     'clear filters
            wrd = "*" & wrdArr(w) & "*"
            ur.AutoFilter Field:=c, Criteria1:=wrd, Operator:=xlFilterValues
            If ur.Columns(c).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
                For Each cel In ur.Columns(c).SpecialCells(xlCellTypeVisible)
                    If Not IsError(cel.Value2) Then
                        If Len(cel.Value2) > 0 Then
                            cVal = cel.Value2:  pos = 1
                            Do While pos > 0
                                pos = InStr(pos, cVal, wrdArr(w), vbTextCompare)
                                wb = Mid(cVal, pos + Len(wrdArr(w)), 1)
                                If pos > 0 And wb Like "[!a-zA-Z0-9]" Then
                                    sz = Len(wrdArr(w))
                                    With cel.Characters(Start:=pos, Length:=sz).Font
                                        .Bold = True
                                        .Color = -4165632
                                        .Size = 11
                                    End With
                                    pos = pos + sz - 1
                                Else
                                    pos = 0
                                End If
                            Loop
                        End If
                    End If
                Next
            End If
            ur.AutoFilter   'clear filters
        Next
    Next
    enableXL True
    Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

Private Sub enableXL(Optional ByVal opt As Boolean = True)
    Application.ScreenUpdating = opt
    Application.EnableEvents = opt
    Application.Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
End Sub

Su código usa ReDim Preserve en el primer ciclo (dos veces)

  • leve impacto en el rendimiento de una celda, pero para miles se vuelve significativo

  • ReDim Preserve hace una copia del arr inicial con la nueva dimensión, luego borra el primer arr

Además, debe evitarse la selección y activación de celdas; la mayoría de las veces no son necesarias y ralentizan la ejecución.


Editar

Medí el rendimiento entre las 2 versiones.

Total cells: 3,060; each cell with 15 words, total search terms: 30

Initial code:               Time: 69.797 sec
My Code:                    Time:  3.969 sec
Initial code optimized:     Time:  3.438 sec

Código inicial optimizado:

Option Explicit

Const ALL_WORDS = "word1,word2,word3"

Public Sub TestMatches()
    Dim searchTerms As Variant, cel As Range, t As Double

    t = Timer
    enableXL False
    searchTerms = Split(ALL_WORDS, ",")
    For Each cel In Sheet1.UsedRange
        ChangeAllMatches searchTerms, cel
    Next
    enableXL True
    Debug.Print "Time: " & Format(Timer - t, "0.000") & " sec"
End Sub

Public Sub ChangeAllMatches(ByRef terms As Variant, ByRef cel As Range)
    Dim termStart() As Long  'this array holds starting positions of each match
    Dim termLen() As Long    'this array holds lengths of each matching substring
    Dim response As Variant, term As Variant, strt As Variant, pos As Long, i As Long

    If IsError(cel.Value2) Then Exit Sub    'Do not process error
    If Len(cel.Value2) = 0 Then Exit Sub    'Do not process empty cells
    response = cel.Value2
    If Len(response) > 0 Then
        ReDim termStart(1 To Len(response)) As Long 'create arrays large enough
        ReDim termLen(1 To Len(response)) As Long   'to accommodate any matches
        i = 1: Dim wb As String
        'The loop finds the starting position & length of each matched term
        For Each term In terms              'Iterate through each term
            strt = 1
            Do
                pos = InStr(strt, response, term, vbTextCompare) 'Check for match
                wb = Mid(response, pos + Len(term), 1)
                If pos > 0 And wb Like "[!a-zA-Z0-9]" Then
                    strt = pos + 1          'Keep looking for more substrings
                    termStart(i) = pos      'Add match starting pos to array
                    termLen(i) = Len(term)  'Add match len to array termLen()
                    i = i + 1
                Else
                    pos = 0
                End If
            Loop While pos > 0  'Keep searching until we find no more matches
        Next
        ReDim Preserve termStart(1 To i - 1) 'clean up array
        ReDim Preserve termLen(1 To i - 1)   'remove extra items at the end
        For i = 1 To UBound(termStart) 'Modify matches based on termStart()
            If termStart(i) > 0 Then
                With cel.Characters(Start:=termStart(i), Length:=termLen(i)).Font
                    .Bold = True
                    .Color = -4165632
                    .Size = 11
                End With
            End If
        Next i
    End If
End Sub
2
paul bica 17 sep. 2017 a las 04:52

Aquí hay un código que desactiva la mayoría de las opciones de VBA que se pueden usar para acelerar la ejecución del código. Al iniciarse, guarda el estado actual; luego apaga todo. Al ser destruido, restaura el estado actual.

Se ingresa como un módulo de clase que debe cambiarse de nombre: SystemState Las instrucciones y los créditos están en el código.

Option Explicit

'
'This class has been developed by my friend & colleague Jon Tidswell.
'I just changed it slightly. Any errors are mine for sure.
'13-Apr-2010 Bernd Plumhoff
'
'The class is called SystemState.
'It can of course be used in nested subroutines.
'
'This module provides a simple way to save and restore key excel
'system state variables that are commonly changed to speed up VBA code
'during long execution sequences.
'
'
'Usage:
'    Save() is called automatically on creation and Restore() on destruction
'    To create a new instance:
'        Dim state as SystemState
'        Set state = New SystemState
'    Warning:
'        "Dim state as New SystemState" does NOT create a new instance
'
'
'    Those wanting to do complicated things can use extended API:
'
'    To save state:
'       Call state.Save()
'
'    To restore state and in cleanup code: (can be safely called multiple times)
'       Call state.Restore()
'
'    To restore Excel to its default state (may upset other applications)
'       Call state.SetDefaults()
'       Call state.Restore()
'
'    To clear a saved state (stops it being restored)
'       Call state.Clear()
'
Private Type m_SystemState
    Calculation As XlCalculation
    Cursor As XlMousePointer
    DisplayAlerts As Boolean
    EnableEvents As Boolean
    Interactive As Boolean
    ScreenUpdating As Boolean
    StatusBar As Variant
    m_saved As Boolean
End Type

'
'Instance local copy of m_State?
'
Private m_State As m_SystemState

'
'Reset a saved system state to application defaults
'Warning: restoring a reset state may upset other applications
'
Public Sub SetDefaults()
    m_State.Calculation = xlCalculationAutomatic
    m_State.Cursor = xlDefault
    m_State.DisplayAlerts = True
    m_State.EnableEvents = True
    m_State.Interactive = True
    m_State.ScreenUpdating = True
    m_State.StatusBar = False
    m_State.m_saved = True ' effectively we saved a default state
End Sub

'
'Clear a saved system state (stop restore)
'
Public Sub Clear()
    m_State.m_saved = False
End Sub

'
'Save system state
'
Public Sub Save(Optional SetFavouriteParams As Boolean = False)
    If Not m_State.m_saved Then
        m_State.Calculation = Application.Calculation
        m_State.Cursor = Application.Cursor
        m_State.DisplayAlerts = Application.DisplayAlerts
        m_State.EnableEvents = Application.EnableEvents
        m_State.Interactive = Application.Interactive
        m_State.ScreenUpdating = Application.ScreenUpdating
        m_State.StatusBar = Application.StatusBar
        m_State.m_saved = True
    End If
    If SetFavouriteParams Then
        Application.Calculation = xlCalculationManual
        'Application.Cursor = xlDefault
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        'Application.Interactive = False
        Application.ScreenUpdating = False
        Application.StatusBar = False
    End If
End Sub

'
'Restore system state
'
Public Sub Restore()
    If m_State.m_saved Then
        Application.Calculation = m_State.Calculation
        Application.Cursor = m_State.Cursor
        Application.DisplayAlerts = m_State.DisplayAlerts
        Application.EnableEvents = m_State.EnableEvents
        Application.Interactive = m_State.Interactive
        Application.ScreenUpdating = m_State.ScreenUpdating
        If m_State.StatusBar = "FALSE" Then
            Application.StatusBar = False
        Else
            Application.StatusBar = m_State.StatusBar
        End If
    End If
End Sub

'
'By default save when we are created
'
Private Sub Class_Initialize()
    Call Save(True)
End Sub

'
'By default restore when we are destroyed
'
Private Sub Class_Terminate()
    Call Restore
End Sub
0
Ron Rosenfeld 16 sep. 2017 a las 10:24