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