• 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
    

      

  • 相关阅读:
    清华大学2015年自主招生暨领军计划试题
    高斯取整函数专题
    国际上的数学比赛
    清华大学数学系本科用什么教材?
    数学人眼中的湖北
    北京十一学校潘国双:激发学习的内在动力
    数学家Erdos的故事
    CentOS7关于网络的设置
    MySQL表连接
    MySQL的sql解析
  • 原文地址:https://www.cnblogs.com/nextseven/p/7271503.html
Copyright © 2020-2023  润新知