这将为每个文件打开一个新示例，然后关闭它。给予看（我无法测试）。这包括我在聊天中提出的所有建议。

Option Explicit

Sub getCBU()
    Dim location As String
    location = "C:\Users\swallin\Documents\CBU History\"

    Dim nextFile As String
    nextFile = Dir(location & "CBU*")

    Dim rowCount As Long
    rowCount = 2

    Dim startTime As Double
    startTime = Timer

    Dim newRow(1 To 17) As Variant, compareRow(1 To 17) As Variant
    Dim lastRow As Long, match As Boolean

    Dim s As Long, x As Long, y As Long, j As Long, v As Long, t As Long

    Dim objExcel As Object, ActWb As Workbook

    Do While nextFile <> ""
        Set objExcel = CreateObject("Excel.Application") 'new excel instance
        Set ActWb = objExcel.Workbooks.Open(Filename:=location & nextFile, ReadOnly:=True)

        lastRow = ActWb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row

        For s = 18 To lastRow
            match = True

            For x = 1 To 17
                newRow(x) = ActWb.Worksheets(1).Cells(s, x)
            Next x

            For y = 2 To rowCount
                If Val(newRow(11)) = Val(ThisWorkbook.Worksheets(1).Cells(y, 11)) Then
                    For j = 1 To 17
                        compareRow(j) = ThisWorkbook.Worksheets(1).Cells(y, j).Value
                    Next j

                    For v = 1 To 17
                        If Val(compareRow(v)) <> Val(newRow(v)) Then
                            match = False
                            Exit For
                        Else
                            match = True
                        End If
                    Next v

                    If match = True Then
                        Exit For
                    End If
                Else
                    match = False
                End If
            Next y

            y = 2

            If match = False Then
                rowCount = rowCount + 1
                For t = 1 To 17
                    ThisWorkbook.Worksheets(1).Cells(rowCount, t) = newRow(t)
                Next t
            End If
        Next s

        s = 18

        ActWb.Close SaveChanges:=False
        objExcel.Quit 'close excel instance
        Set objExcel = Nothing 'free variable

        nextFile = Dir()
    Loop

    Dim secondsElapsed As String
    secondsElapsed = Format$((Timer - startTime) / 86400, "hh:mm:ss")
    ThisWorkbook.Worksheets(2).Cells(1, 1) = secondsElapsed
End Sub

不确定写回工作表部分（我仍然会将值分配给一个数组并一起写回，但这取决于你在工作表中已经有了什么，再加上newRow()所做的），但你能试试看是否有任何速度上的改进吗？

Sub getCBU()

Dim rowCount As Long, newRow(1 To 17) As Variant, compareRow(1 To 17) As Variant, nextFile As String
Dim location As String, lastRow As Long, match As Boolean, startTime As Double, secondsElapsed As String

Dim arrData, arrOutput()
Dim arrTemp(): ReDim arrOutput(1 To 17, 1 To 1)
Dim R As Long, C As Long

location = "C:\Users\swallin\Documents\CBU History\"
nextFile = Dir(location & "CBU*")
rowCount = 2

startTime = Timer

Do While nextFile <> ""

    Workbooks.Open (location & nextFile)
    lastRow = Workbooks(nextFile).Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row
    With Workbooks(nextFile).Worksheets(1)
        arrData = .Range(.Cells(1, 1), .Cells(lastRow, 17))
    End With

    For s = 18 To lastRow

        match = True

        For X = 1 To 17
            newRow(X) = arrData(s, X)
        Next X

        For y = 2 To rowCount

            If Val(newRow(11)) = Val(arrData(y, 11)) Then

                For j = 1 To 17
                    compareRow(j) = arrData(y, j).Value
                Next j

                For v = 1 To 17
                    If Val(compareRow(v)) <> Val(newRow(v)) Then
                        match = False
                        Exit For
                    Else
                        match = True
                    End If
                Next v

                If match = True Then
                    Exit For
                End If

            Else
                match = False
            End If

        Next y

        y = 2

        If match = False Then
            rowCount = rowCount + 1
            ReDim Preserve arrTemp(1 To 17, 1 To rowCount)
            For t = 1 To 17
                arrTemp(t, rowCount) = newRow(t)
            Next t
        End If

    Next s

    s = 18

    Workbooks(nextFile).Close

    nextFile = Dir()

Loop

    'Transpose the array
    ReDim arrOutput(1 To UBound(arrTemp, 2), 1 To UBound(arrTemp))
    For C = LBound(arrTemp) To UBound(arrTemp)
        For R = LBound(arrTemp, 2) To UBound(arrTemp, 2)
            arrOutput(R, C) = arrTemp(C, R)
        Next R
    Next C

    'Allocate back to the spreadsheet
    With ThisWorkbook.Worksheets(1)
        .Range(.Cells(2, 1), .Cells(UBound(arrOutput) + 1, 17)) = arrOutput
    End With

secondsElapsed = Format((Timer - startTime) / 86400, "hh:mm:ss")
ThisWorkbook.Worksheets(2).Cells(1, 1) = secondsElapsed

End Sub

PS：正如其他人建议的那样，使用Option Explicit是一个好主意，并最终逐步执行代码，看看是否一切都按预期工作。
至于溢出问题……逐步通过代码最终也会/应该解决这个问题。请参阅Overflow (Error 6)了解更多信息。

**编辑：**我已经添加了进一步的管理来保存数组中的值，并写回电子表格。

下面是对代码的改进，它应该更快，更友好。（更新为能够处理任何数量的结果）。

Sub getCBU()

    Dim wb As Workbook
    Dim wsDest As Worksheet
    Dim wsTime As Worksheet
    Dim hUnqVals As Object
    Dim hUnqRows As Object
    Dim aHeaders() As Variant
    Dim aCompare() As Variant
    Dim aResults() As Variant
    Dim aStartingData() As Variant
    Dim sFolder As String
    Dim sFile As String
    Dim sDelim As String
    Dim sTemp As String
    Dim lMaxResults As Long
    Dim lCompareStartRow As Long
    Dim lValCompareCol As Long
    Dim ixCompare As Long
    Dim ixResult As Long
    Dim ixCol As Long
    Dim dTimer As Double

    dTimer = Timer

    Set wb = ThisWorkbook
    Set wsDest = wb.Worksheets(1)
    Set wsTime = wb.Worksheets(2)
    Set hUnqRows = CreateObject("Scripting.Dictionary")
    Set hUnqVals = CreateObject("Scripting.Dictionary")
    sDelim = "|"
    lMaxResults = 100000
    lCompareStartRow = 18
    lValCompareCol = 11

    sFolder = Environ("UserProfile") & "\Documents\CBU History\"    'Be sure to including ending \
    sFile = Dir(sFolder & "CBU*.xlsx")

    With wsDest.Range("A2:Q" & wsDest.Cells(wsDest.Rows.Count, lValCompareCol).End(xlUp).Row)
        If .Row > 1 Then
            aHeaders = .Offset(-1).Resize(1).Value
            aStartingData = .Value
            ReDim aResults(1 To lMaxResults, 1 To .Columns.Count)
            For ixResult = 1 To UBound(aStartingData, 1)
                For ixCol = 1 To UBound(aStartingData, 2)
                    sTemp = sTemp & sDelim & aStartingData(ixResult, ixCol)
                Next ixCol
                If Not hUnqRows.Exists(sTemp) Then hUnqRows.Add sTemp, sTemp
                If Not hUnqVals.Exists(aStartingData(ixResult, lValCompareCol)) Then hUnqVals.Add aStartingData(ixResult, lValCompareCol), aStartingData(ixResult, lValCompareCol)
                sTemp = vbNullString
            Next ixResult
            Erase aStartingData
        Else
            'No data to compare against, so no data can be added, exit macro
            MsgBox "No data found in [" & wsDest.Name & "]" & Chr(10) & "Exiting Macro.", , "Error"
            Exit Sub
        End If
    End With

    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    ixResult = 0
    Do While Len(sFile) > 0
        Application.StatusBar = "Processing " & sFile & "..."
        With Workbooks.Open(sFolder & sFile, , True).Worksheets(1)
            With .Range("A" & lCompareStartRow & ":Q" & .Cells(.Rows.Count, lValCompareCol).End(xlUp).Row)
                If .Row >= lCompareStartRow Then
                    aCompare = .Value
                    For ixCompare = 1 To UBound(aCompare, 1)
                        If hUnqVals.Exists(aCompare(ixCompare, lValCompareCol)) Then
                            For ixCol = 1 To UBound(aCompare, 2)
                                sTemp = sTemp & sDelim & aCompare(ixCompare, ixCol)
                            Next ixCol
                            If Not hUnqRows.Exists(sTemp) Then
                                hUnqRows.Add sTemp, sTemp
                                ixResult = ixResult + 1
                                For ixCol = 1 To UBound(aCompare, 2)
                                    aResults(ixResult, ixCol) = aCompare(ixCompare, ixCol)
                                Next ixCol
                                If ixResult = lMaxResults Then OutputResults wsDest, aResults, ixResult, aHeaders
                            End If
                            sTemp = vbNullString
                        End If
                    Next ixCompare
                    Erase aCompare
                End If
            End With
            .Parent.Close False
        End With
        sFile = Dir()
    Loop

    Application.StatusBar = vbNullString
    If ixResult > 0 Then OutputResults wsDest, aResults, ixResult, aHeaders
    wsTime.Range("A1").Value = Format((Timer - dTimer) / 86400, "hh:mm:ss")

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Sub OutputResults(ByRef arg_ws As Worksheet, ByRef arg_aResults As Variant, ByRef arg_ixResult As Long, ByVal arg_aHeaders As Variant)

    Static wsDest As Worksheet
    Dim rDest As Range
    Dim lMaxRows As Long
    Dim lMaxCols As Long

    If wsDest Is Nothing Then Set wsDest = arg_ws
    lMaxRows = UBound(arg_aResults, 1)
    lMaxCols = UBound(arg_aResults, 2)

    Set rDest = wsDest.Range("A1").Resize(, lMaxCols).EntireColumn.Find("*", wsDest.Range("A1"), xlValues, xlWhole, , xlPrevious)
    If rDest Is Nothing Then Set rDest = wsDest.Range("A2") Else Set rDest = wsDest.Cells(rDest.Row, "A")

    If rDest.Row + 1 + arg_ixResult > wsDest.Rows.Count Then
        Set wsDest = wsDest.Parent.Worksheets.Add(After:=wsDest)
        With wsDest.Range("A1").Resize(, lMaxCols)
            .Value = arg_aHeaders
            .Font.Bold = True
        End With
        Set rDest = wsDest.Range("A2")
    End If

    rDest.Resize(arg_ixResult, lMaxCols).Value = arg_aResults

    Erase arg_aResults
    ReDim arg_aResults(1 To lMaxRows, 1 To lMaxCols)

End Sub