zoukankan      html  css  js  c++  java
  • 20190321xlVBA_明细信息表汇总成数据表

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

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

    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
    

      

  • 相关阅读:
    09.回文数
    08.字符串转换位整数
    背景图片自适应
    认证 (authentication) 和授权 (authorization) 的区别
    vue-组件之间传值
    数组对象去重
    二进制数转换十进制数
    node-删除对象中指定属性失效问题-JSON.parse实例化
    Vue-动态修改数组
    正则遇到的问题集合
  • 原文地址:https://www.cnblogs.com/nextseven/p/10575370.html
Copyright © 2011-2022 走看看