优化 Excel VBA 复制粘贴值的宏

Question

我是 Excel-VBA 的新手，我需要提高微距性能。我有一个宏，用于搜索 excel，打开它，然后遍历每个 sheet 并为具有特定颜色（黄色）的所有单元格复制粘贴值。最后保存并关闭excel。此外，excels sheets 被锁定，只有那些黄色单元格是可编辑的。这应该针对我在调用宏的主模板中指示的 excel 列表完成。问题是，当excel的个数超过3个时，会非常耗时，甚至会被阻塞。

我把我的代码贴在下面，希望有人能帮忙。谢谢！

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

未经测试 - 只是一些“开始”的想法供您使用（例如，没有选择，使用数组，修复 With 语句，没有 GoTo）。我不明白清除 vbNullstring 背后的逻辑。如果有必要以您的方式调整代码。

我还建议打开显示警报的文件，因为很少有潜在问题（例如，“上次打开文件时发生严重错误”会挂起您的宏）

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

优化 Excel VBA 复制粘贴值的宏

Optimize Excel VBA Macro for Copy-PasteValues

excel

optimization

vba

copy-paste