20170801xlVBA含有公式出现弹窗合并

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Public Sub GatherDataPicker()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"
 
    'On Error GoTo ErrHandler
 
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim wb As Workbook
    Dim Sht As Worksheet
 
    Dim EndRow As Long
 
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Const SHEET_INDEX = "DB-B01" '"DB-C01"    '引号内修改的是Sheet Name 表名(有人也叫页名)
    Const TITLE_ROW As Long = 2    '这里修改的是标题所占的行数
 
    Dim FolderPath As String
    Dim FileName As String
    Dim FileCount As Long
 
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        .Title = "请选取Excel工作簿所在文件夹"
        If .Show = -1 Then
            FolderPath = .SelectedItems(1)
        Else
            MsgBox "您没有选中任何文件夹，本次汇总中断！"
            Exit Sub
        End If
    End With
    If Right(FolderPath, 1) <> "\" Then FolderPath = FolderPath & "\"
 
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set wb = Application.ThisWorkbook    '工作簿级别
    Set Sht = wb.Worksheets(1)
    Sht.Cells.Clear
 
    'FolderPath = ThisWorkbook.Path & "\"
    FileCount = 0
    FileName = Dir(FolderPath & "*.xls*")
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then
            FileCount = FileCount + 1
            Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)
            'Sleep 5000
            'SendKeys "~"
 
            With OpenWb
                Set OpenSht = .Worksheets(SHEET_INDEX)
                With OpenSht
                    EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
                    If FileCount = 1 Then
                        Set Rng = .Range("A1:ADT" & EndRow)
                        Rng.Copy
                        Sht.Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    Else
                        Set Rng = .Range("A" & TITLE_ROW + 1 & ":ADT" & EndRow)
                        EndRow = Sht.Cells.Find("*", Sht.Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
                        Rng.Copy
                        Sht.Cells(EndRow + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    End If
                End With
                .Close False
            End With
        End If
        FileName = Dir
    Loop
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次耗时：" & Format(UsedTime, "0.000秒"), vbOKOnly, " Excel Studio QQ84857038"
 
ErrorExit:
    Set wb = Nothing
    Set Sht = Nothing
    Set OpenWb = Nothing
    Set OpenSht = Nothing
    Set Rng = Nothing
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "！" & FileName, vbCritical, " Excel Studio QQ84857038"
 
        Err.Clear
        Resume ErrorExit
    End If
End Sub