合并工作表并使用查找/替换

Question

在我这些天投入大量旋转的宏中，这个宏运行得最慢。~4-5秒取决于文件的大小。这并不多，但我想知道为什么代码16x的运行时间要长得多。

根据文档的名称，代码尝试合并文档(通常是2个excel文档，最多5个)，然后将它们重命名为我所需要的。然后，另一个大问题是使用查找/替换来修复一系列Unicode/字符问题。我情不自禁地认为这件事可以处理得更好。

我想找出这段代码中的瓶颈所在，如何处理这些Unicode问题，更好地执行Find/replace，以及如何执行更好的VBA实践。

Option Explicit
Sub MergeBooks()
Dim wb As Workbook
Dim ws As Worksheet

On Error GoTo Handler:
Application.ScreenUpdating = False
For Each wb In Application.Workbooks
    If wb.Name <> "CompanyBook.xlsm" Then
        If FindString(wb.Name, "Report2") Then
            wb.Worksheets.Move after:=Workbooks("CompanyBook.xlsm").Sheets("Aggregate")
        ElseIf FindString(wb.Name, "Report1") Then
            wb.Worksheets.Move after:=Workbooks("CompanyBook.xlsm").Sheets("Aggregate")
        End If
    End If
Next

For Each ws In Workbooks("CompanyBook.xlsm").Worksheets
    If FindString(ws.Name, "Report2") Then
        ws.Name = "Report2"
    ElseIf FindString(ws.Name, "Report1") Then
        ws.Name = "Report1"
    End If
Next ws

'Char mishap replacements
With Workbooks("CompanyBook.xlsm")
.Worksheets("Report1").Cells.Replace What:="&", Replacement:="&", LookAt:=xlPart, MatchCase:=False
.Worksheets("Report1").Cells.Replace What:=""", Replacement:=Chr(34), LookAt:=xlPart, MatchCase:=False
.Worksheets("Report2").Cells.Replace What:="’", Replacement:="’", LookAt:=xlPart, MatchCase:=False
.Worksheets("Report2").Cells.Replace What:="…", Replacement:="…", LookAt:=xlPart, MatchCase:=False
.Worksheets("Report2").Cells.Replace What:="£", Replacement:="£", LookAt:=xlPart, MatchCase:=False
'.Worksheets("Report2").Cells.Replace What:="‘", Replacement:="‘L", LookAt:=xlPart, MatchCase:=False
.Worksheets("Company").Select
End With

Application.ScreenUpdating = True
Exit Sub
Handler:
Application.ScreenUpdating = True
MsgBox "Please make sure that one and only one type of each database file is open.", vbExclamation, "Merge Documents"
End Sub
Function FindString(strCheck As String, strFind As String) As Boolean
Dim intPos As Integer
    intPos = InStr(strCheck, strFind)
    FindString = intPos > 0
End Function

Answer 1

为了补充加菲的建议，我认为你将从改变这一点中受益：

'Char mishap replacements
With Workbooks("CompanyBook.xlsm")
.Worksheets("Report1").Cells.Replace What:=""", Replacement:=Chr(34), LookAt:=xlPart, MatchCase:=False
.Worksheets("Report2").Cells.Replace What:="’", Replacement:="’", LookAt:=xlPart, MatchCase:=False
.Worksheets("Report2").Cells.Replace What:="…", Replacement:="…", LookAt:=xlPart, MatchCase:=False
.Worksheets("Report2").Cells.Replace What:="£", Replacement:="£", LookAt:=xlPart, MatchCase:=False
'.Worksheets("Report2").Cells.Replace What:="‘", Replacement:="‘L", LookAt:=xlPart, MatchCase:=False
.Worksheets("Company").Select
End With

对此：

Dim r1 As Excel.Range, r2 As Excel.Range
Set r1 = Workbooks("CompanyBook.xlsm").Worksheets("Report1").Cells.SpecialCells(xlCellTypeConstants)
Set r2 = Workbooks("CompanyBook.xlsm").Worksheets("Report2").Cells.SpecialCells(xlCellTypeConstants)

With r1
    .Replace What:="&", Replacement:="&", LookAt:=xlPart, MatchCase:=False
    .Replace What:=""", Replacement:=Chr(34), LookAt:=xlPart, MatchCase:=False
End With

With r2
    .Replace What:="…", Replacement:="…", LookAt:=xlPart, MatchCase:=False
    .Replace What:="£", Replacement:="£", LookAt:=xlPart, MatchCase:=False
End With

通过这种方式，您可以将选择缩小到只有需要Excel查找/替换内容的单元格。另外，因为您将范围设置为变量一次，所以Excel不必像现在一样多次搜索所有单元格。

Answer 2

性能最低的总是必须刷新显示信息。如果您必须在工作表之间切换，则会增加时间延迟的焦点分配。

Application.ScreenUpdating = False

除了优化您已经建议的，也许您应该考虑重写您自己的替换函数的可能性。我看你在所有电话中都使用相同的参数。

LookAt: = xlPart, 
MatchCase: = False 

VB函数包含为许多不同参数准备的算法。对于你真正需要的东西来说太复杂了，但是它总是不那么快地使用自己的功能，并且100%地为你的目标设计。

如果执行速度是您的优先事项，您应该重新发明车轮，但看起来更糟的编码。

其他一般建议将直接访问单元格的值，而不必先选择它们。

Answer 3

不是为了效率但你可以从这个开始..。转换此块：

If FindString(wb.Name, "Report2") Then
    wb.Worksheets.Move after:=Workbooks("CompanyBook.xlsm").Sheets("Aggregate")
ElseIf FindString(wb.Name, "Report1") Then
    wb.Worksheets.Move after:=Workbooks("CompanyBook.xlsm").Sheets("Aggregate")
End If

以下各点：

If FindString(wb.Name, "Report2") or FindString(wb.Name, "Report1") Then
    wb.Worksheets.Move after:=Workbooks("CompanyBook.xlsm").Sheets("Aggregate")
End If

而且，看起来您的FindString函数与您在其中使用的InStr几乎完全相同(只是转换为Boolean)，那么为什么不直接使用InStr呢？

即

If FindString(ws.Name, "Report2") Then

更改为

If InStr(ws.Name, "Report2") > 0 Then

对于特定的问题，您可以对字符串变量执行替换操作，并将该值写回单元格，而不是每次在单元格上搜索。访问实际的单元格非常缓慢。改变这一点：

With Workbooks("CompanyBook.xlsm")
.Worksheets("Report1").Cells.Replace What:="&", Replacement:="&", LookAt:=xlPart, MatchCase:=False
.Worksheets("Report1").Cells.Replace What:=""", Replacement:=Chr(34), LookAt:=xlPart, MatchCase:=False
.Worksheets("Report2").Cells.Replace What:="’", Replacement:="’", LookAt:=xlPart, MatchCase:=False
.Worksheets("Report2").Cells.Replace What:="…", Replacement:="…", LookAt:=xlPart, MatchCase:=False
.Worksheets("Report2").Cells.Replace What:="£", Replacement:="£", LookAt:=xlPart, MatchCase:=False
'.Worksheets("Report2").Cells.Replace What:="‘", Replacement:="‘L", LookAt:=xlPart, MatchCase:=False
.Worksheets("Company").Select
End With

像这样的事情：

With Workbooks("CompanyBook.xlsm")
    For Each varCell In .Worksheets("Report1").Cells ' THIS IS VERY BIG AND YOU SHOULD CONSIDER REFINING YOUR RANGE
        TempVal = varCell.Value2
        TempVal = Replace(TempVal, "&", "&")
        'and so on for all your replacements
        varCell.Value = TempVal
    Next varCell
End With