20170617xlVBA调查问卷基础数据分类计数

Public Sub GatherDataPicker()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ">>>>>>>>程序正在运行>>>>>>>>"
    Dim Dic As Object

    On Error GoTo ErrHandler

    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Const SHEET_INDEX = 1
    Const OFFSET_ROW As Long = 1

    Dim FolderPath As String
    Dim FileName As String
    Dim FileCount As Long
    Dim qIndex As String

    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    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.ActiveSheet
    Sht.UsedRange.Offset(0, 2).ClearContents

    'FolderPath = ThisWorkbook.Path & "\"
    FileCount = 0
    FileName = Dir(FolderPath & "*.xls*")
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then
            Set Dic = CreateObject("Scripting.Dictionary")
            FileCount = FileCount + 1
            Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)
            With OpenWb
                Set OpenSht = OpenWb.Worksheets(1)
                With OpenSht
                    endrow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
                    Set Rng = .Range("a1").CurrentRegion
                    arr = Rng.Value
                    For j = LBound(arr, 2) + 1 To UBound(arr, 2)
                        For i = LBound(arr) + 1 To UBound(arr)
                            FileName = Split(FileName, ".")(0)
                            qIndex = Replace(arr(1, j), "Q", "")
                            Key = CStr(arr(i, j))
                            'Dim uk As String
                            uk = FileName & ";" & qIndex & ";" & Key
                            Dic(uk) = Dic(uk) + 1
                            'Debug.Print FileName, "   "; qIndex
                        Next i
                    Next j
                End With
                .Close False
            End With

            With Sht
                endcol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column + 1
                endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row

                .Cells(1, endcol).Value = FileName

                For i = 3 To endrow
                    If .Cells(i, 1).Value <> "" Then qIndex = .Cells(i, 1).Value
                    Key = .Cells(i, 2).Value

                    Debug.Print i; "   "; qIndex

                    If Key <> "无效" Then
                        uk = FileName & ";" & qIndex & ";" & Key
                        .Cells(i, endcol).Value = Dic(uk)
                        Dic.Remove uk
                    Else
                        mysum = 0
                        uk = FileName & ";" & qIndex & ";"
                        For Each k In Dic.keys
                            If InStr(1, k, uk) > 0 Then mysum = mysum + Dic(k)
                        Next k
                        .Cells(i, endcol).Value = mysum
                    End If
                Next i
            End With

        End If
        FileName = Dir
    Loop
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime

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 & "！", vbCritical, "NextSeven Excel Studio"
        'Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub