Optimize Excel VBA Macro for Copy-PasteValues - excel

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

Answer 1

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