Optimize Excel VBA Macro for Copy-PasteValues

Question

I'm new in Excel-VBA and I need to improve my macro performance. I have a macro that searches an excel, opens it, then goes through every sheet and copy-pastevalues for all cell with a specific color (yellow). Finally saves and closes the excel. In addition, excels sheets are locked and only those yellow cells are editable. This should be done for a list of excel that I indicate in a main template from where I call the macro. The problem is that it takes a lot of time and even gets blocked when the number of excels is more than 3.

I paste my code below and hope anyone can help. Thanks!

Sub Button1_Click()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim filePath As String
    Dim rng As Range
    Dim cel As Range
    Dim cartera As String
    Dim plantilla As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim obj_Cell As Range

    filePath = Application.ThisWorkbook.Path
    
    Range("B9").Select
    Set rng = Application.Range(Selection, Selection.End(xlDown))
    
    For Each cel In rng.Cells
        cartera = cel.Value
        plantilla = cel.Offset(0, 1).Value
        
        If cartera = vbNullString Or plantilla = vbNullString Then
            GoTo Saltar
        End If
        
        Application.StatusBar = "Ejecutando Cartera: " & cartera & ", Plantilla: " & plantilla
        
        Set wb = Workbooks.Open(filePath & "\" & cartera & "\" & plantilla, UpdateLinks:=3)
        
        For Each ws In wb.Worksheets
            If ws.Name <> "Index" And ws.Name <> "Instructions" And ws.Name <> "Glossary" Then
                Worksheets(ws.Name).Activate
                For Each obj_Cell In Range("A1:DW105")
    
                    With obj_Cell
                        If obj_Cell.Interior.Color = RGB(255, 255, 153) Then
                            obj_Cell.Select
                            If obj_Cell.MergeCells = True Then
                                obj_Cell.MergeArea.Select
                            End If
                            Selection.Copy
                            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
                            If obj_Cell.MergeCells = True Then
                                If obj_Cell.MergeArea(1).Value = vbNullString Then
                                    obj_Cell.MergeArea.Cells(1, 1).Select
                                    Selection.ClearContents
                                End If
                            Else
                                If obj_Cell.Value = vbNullString Then
                                    obj_Cell.ClearContents
                                End If
                            End If
                        End If
                    End With
                    
                Next obj_Cell
                
                Range("A1").Select
            End If
        Next ws
        
        Sheets(1).Select
        wb.Close SaveChanges:=True
        
Saltar:

    Next cel
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
End Sub

user_4929971 · Answer

Untested- just some "start" ideas for you to use (e.g. no selections, using arrays, fix With statement, no GoTo). I don't understand the logic behind clearing vbNullstring. If it is necessary adapt the code in your way.

I would also suggest opening files with displayalerts on because of few potential problems (e.g. "serious error occur last time file was opened" would hangs your macro)

Sub Button1_Click()

    With Application
        .ScreenUpdating = False
        .StatusBar = True
    End With
    
    ' If possible change this reference
    ' from active sheet to sheet's name/codename/index
    Dim activeWs As Worksheet
    Set activeWs = ActiveSheet
    
    Dim filePath As String
        filePath = Application.ThisWorkbook.Path
    
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim obj_Cell As Range
    
    ' range definition
    ' if lastRow not working change to yours xlDown
    ' if possible End(xlUp) method is more reliable
    Dim rng As Range
    Dim lastRw As Long
    With activeWs
        lastRw = .Cells(.Cells.Rows.Count, "B").End(xlUp).Row
        Set rng = .Range("B9:B" & lastRw)
    End With

    ' read whole ranges at once
    ' instead of offset it is possible also to read
    ' cartera and plantilla at the same time to 2Darray
    Dim cartera As Variant
        cartera = Application.Transpose(rng.Value2)
    Dim plantilla As Variant
        plantilla = Application.Transpose(rng.Offset(, 1).Value2)
    
    ' main loop
    Dim i As Long
    For i = 1 To UBound(cartera)
    If cartera(i) <> vbNullString Or plantilla(i) <> vbNullString Then
        
        Application.StatusBar = "Ejecutando Cartera: " & cartera(i) & ", Plantilla: " & plantilla(i)
        
        Set wb = Workbooks.Open(filePath & "\" & cartera(i) & "\" & plantilla(i), UpdateLinks:=3)
        
        For Each ws In wb.Worksheets
        
            If ws.Name <> "Index" And ws.Name <> "Instructions" And ws.Name <> "Glossary" Then

                For Each obj_Cell In ws.Range("A1:DW105")
    
                    With obj_Cell
                        If .Interior.Color = RGB(255, 255, 153) Then
                            .Value2 = .Value2
                            
                        ' I commented this part beacuse it does not make sense for me...
'                            If .MergeCells Then
'                                If .MergeArea(1).Value = vbNullString Then _
                                        .MergeArea.Cells(1, 1).ClearContents
'                            Else
'                                If .Value = vbNullString Then .ClearContents
'                            End If
                            
                        End If
                        
                    End With
                    
                Next obj_Cell
                
            End If
        Next ws
        
        ' I would place diplayalerts off here because of potential problems
        ' with opening files
        ' if problem occurs it can macro hangs
        Application.DisplayAlerts = False
            wb.Close SaveChanges:=True
        Application.DisplayAlerts = True
        
    End If
    Next i
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .StatusBar = False
    End With
    
End Sub

Optimize Excel VBA Macro for Copy-PasteValues

1 Answers