Merging worksheets and using find/replace

Question

Of all the macros that I put into heavy rotation these days, this one is running the slowest. ~4-5 seconds depending on the size of the files. It's not a lot but I'd like to know why code 16x as long is running much more instantly.

The code tries to merge documents (usually 2 excel docs out of at most 5) depending on their names and then rename those to exactly what I need. Then, another big issue, is using find/replace to fix a bunch of Unicode/character issues. I cant help but think that could be handled better.

I'd like to find out where the bottlenecks in this code are, how to handle these Unicode issues, perform the Find/replace better, and all in all how to execute better VBA practices.

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:="&amp;", Replacement:="&", LookAt:=xlPart, MatchCase:=False
.Worksheets("Report1").Cells.Replace What:="&quot;", 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

To supplement Gaffi's suggestions, I think you would benefit from changing this:

'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

To this:

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

This way, you narrow down the selection to only cells that have content for Excel to find/replace. Also, because you set the range to a variable once, Excel doesn't have to search through all cells multiple times like it is now.

Answer 2

What lowest performance is always having to refresh the display information. And if you have to switch between sheets, time delays are added focus allocation.

Application.ScreenUpdating = False

Besides optimizing You've already suggested, maybe you should think about the possibility of rewriting your own Replace function. I see you're using the same parameters in all calls.

LookAt: = xlPart, 
MatchCase: = False 

The VB functions contain algorithms prepared for many different parameters. Are too complex for what you really need but it will always be less quick to use own functions and 100% designed for your target.

If execution speed is your priority, you should reinvent the wheel but look worse encoded.

Other general advice would directly access the value of the cells, without having to select them first.

Answer 3

Not for efficiency, but you can start with this... Convert this block:

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

to the following:

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

Also, it looks like your FindString function is almost identical (just converting to Boolean) to the InStr you use within it, so why not just use InStr?

i.e.

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

change to

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

For your specific question, you can do your replace on a string variable and write that value back to the cell, rather than search on the cell each time. Accessing the actual cell is very slow. Change this:

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

To something like this:

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