针对复制粘贴值优化Excel VBA宏

debugcn 发表于 Dev

Manu_9293

我是Excel-VBA的新手，我需要提高宏性能。我有一个宏，可以搜索一个excel，将其打开，然后遍历每个工作表并为具有特定颜色（黄色）的所有单元格复制粘贴值。最后保存并关闭excel。此外，excel工作表被锁定，只有那些黄色单元格是可编辑的。我应该在我从宏调用的主模板中指出的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

RafałB.

未经测试-只是一些“开始”的想法供您使用（例如，没有选择，使用数组，fix 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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。