刚开始能把代码敲得行云流水的时候,写代码是种乐趣。有了功利目的之后,重复的工作写多几次,厌烦的情绪四处弥漫。
去年八月份正好写了一回,还能支持控件,在此备忘。
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