20190321xlVBA_明细信息表汇总成数据表

Posted 2021-02-14 nextseven

刚开始能把代码敲得行云流水的时候，写代码是种乐趣。有了功利目的之后，重复的工作写多几次，厌烦的情绪四处弥漫。

 

去年八月份正好写了一回，还能支持控件，在此备忘。

Public Sub InformationToTable()
    ‘关联表为
    ‘A列是信息登记表的单元格地址
    ‘如果有Chcek控件 则为_CheckBox1/_CheckBox2
    ‘B列为汇总表输出的列名
    Application.DisplayAlerts = False
    
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.Dictionary")
    
    Dim wb As Workbook
    Dim sht As Worksheet
    Dim OpenWb As Workbook
    Dim OpenSht As Worksheet
    Dim Rng As Range
    Dim index As Long
    Dim myShop, myDate, myHeader
    Set wb = Application.ThisWorkbook
    Set sht = wb.Worksheets("信息汇总")
    Set rsht = wb.Worksheets("关联表")
    With rsht
        endrow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        For i = 2 To endrow
            Key = .Cells(i, 1).Value
            Dic(Key) = .Cells(i, 2).Value
        Next i
    End With
    sht.UsedRange.Offset(1).Clear
    
    Dim FolderPath 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) <> Application.PathSeparator Then FolderPath = FolderPath & Application.PathSeparator
    
    frr = FsoGetFiles(FolderPath, "*.xls*")
    index = 1
    For f = LBound(frr) To UBound(frr)
        If frr(f) <> wb.Path Then
            index = index + 1
            filepath = frr(f)
            
            Set OpenWb = Application.Workbooks.Open(filepath)
            Set OpenSht = OpenWb.Worksheets(1)
            With OpenSht
                For Each k In Dic.keys
                    If Left(k, 1) = "_" Then
                        cts = Split(k, "/")
                        For Each ct In cts
                            If .OLEObjects(Replace(ct, "_", "")).Object.Value = True Then
                                sht.Cells(index, Dic(k)).Value = .OLEObjects(Replace(ct, "_", "")).Object.Caption
                            End If
                        Next ct
                    Else
                        sht.Cells(index, Dic(k)).Value = .Range(k).Value
                    End If
                Next k
            End With
            OpenWb.Close False
        End If
    Next f
    
    
    
    Set Dic = Nothing
    Set wb = Nothing
    Set sht = Nothing
    Set rsht = Nothing
    Set OpenWb = Nothing
    Set OpenSht = Nothing
    
    
    Application.DisplayAlerts = True
    
    ‘MsgBox "汇总完成！"
End Sub
Function FsoGetFiles(ByVal FolderPath As String, ByVal Pattern As String, Optional ComplementPattern As String = "") As String()
    Dim Arr() As String
    Dim FSO As Object
    Dim ThisFolder As Object
    Dim OneFile As Object
    ReDim Arr(1 To 1)
    Arr(1) = "None"
    Dim index As Long
    index = 0
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error GoTo ErrorExit
    Set ThisFolder = FSO.getfolder(FolderPath)
    If Err.Number <> 0 Then Exit Function
    For Each OneFile In ThisFolder.Files
        If OneFile.Name Like Pattern Then
            If Len(ComplementPattern) > 0 Then
                If Not OneFile.Name Like ComplementPattern Then
                    index = index + 1
                    ReDim Preserve Arr(1 To index)
                    Arr(index) = OneFile.Path
                End If
            Else
                index = index + 1
                ReDim Preserve Arr(1 To index)
                Arr(index) = OneFile.Path
            End If
        End If
    Next OneFile
ErrorExit:
    FsoGetFiles = Arr
    Erase Arr
    Set FSO = Nothing
    Set ThisFolder = Nothing
    Set OneFile = Nothing
End Function