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
    

      

  • 相关阅读:
    HDU4529 郑厂长系列故事——N骑士问题 —— 状压DP
    POJ1185 炮兵阵地 —— 状压DP
    BZOJ1415 聪聪和可可 —— 期望 记忆化搜索
    TopCoder SRM420 Div1 RedIsGood —— 期望
    LightOJ
    LightOJ
    后缀数组小结
    URAL
    POJ3581 Sequence —— 后缀数组
    hdu 5269 ZYB loves Xor I
  • 原文地址:https://www.cnblogs.com/nextseven/p/10575370.html
Copyright © 2011-2022 走看看