excel - 优化复制粘贴值的 Excel VBA 宏
问题描述
我是 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
解决方案
未经测试 - 只是一些“开始”的想法供您使用(例如,没有选择,使用数组,修复 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
推荐阅读
- reactjs - 如何在我的 react/django 网站上显示来自 blob 存储的图像
- authentication - GSM移动网络中Ki唯一性的原因
- javascript - 在弹出窗口中显示可编辑的可编辑表单
- azure - 存储帐户中的 Terraform 状态文件
- r - 在 R 中提取相交值
- angular - ngx-formly 中表单字段的更改事件
- google-apps-script - 将传感器数据从 ESP8266 发送到 Google 表格
- flutter - Flutter - 如何使 ListTile(或 Row)的内容居中(垂直)?
- flutter - 如何在下拉列表中动态添加数据?
- python - 在excel中导出格式时出现openpyxl问题