制作一本带有从儿童中提取数据的表的大师级作品

In my directory c:/test I have multiple workbooks named "xx-xxxxx.xlsm" where "xx-xxxxx" is the registrationnumber of the car that is documented in the specific file.

在我的目录c:/ test中我有多个名为“xx-xxxxx.xlsm”的工作簿,其中“xx-xxxxx”是特定文件中记录的汽车的注册号。

In all the xx-xxxxx.xlsm files there is a sheet named "Summary", and in this sheet, the data structure is the same in all the workbooks - b1 is the reg.nr., b2 is cartype, b3 is the purchase date, b4 is the user etc.

在所有xx-xxxxx.xlsm文件中都有一个名为“Summary”的工作表,在此工作表中,所有工作簿中的数据结构相同 - b1是reg.nr.,b2是cartype,b3是购买日期,b4是用户等。

Now I want to make a masterworkbook with a masterTABLE sheet that sums up all the summarysheets in one table without opening the individual workbooks. In this table I have the reg.no in column A, cartype in column B, purchasedate in column C, user in column D and so forth.

现在我想制作一个带有masterTABLE表的masterworkbook,它总结了一个表中的所有summarysheets而无需打开单独的工作簿。在此表中,我在列A中有reg.no,在列B中有cartype,在列C中购买,在列D中有用户,依此类推。

The obvious solution is to make a formula saying ='C:/test/[xx-xxxxx.xlsm]Table'!$b$2, and then manually insert the appropriate file name. But since I have the reg.no. in the first column in the master table and the same reg.no in the file name (and MANY cars/files/rows/columns), I would like to have a formula like ='C:/test/[b2]Table'!$b$2 or VLOOKUP and just copy it down each column/row. But this of course does not work.

显而易见的解决方案是制作一个公式:='C:/ test / [xx-xxxxx.xlsm] Table'!$ b $ 2,然后手动插入相应的文件名。但是因为我有reg.no.在主表的第一列和文件名中的相同reg.no(以及MANY cars / files / rows / columns)中,我希望有一个像''C:/ test / [b2] Table'这样的公式!$ b $ 2或VLOOKUP并将其复制到每列/每行。但这当然不起作用。

I have tried other solutions on similar challenges suggested by other users in this and other forums , but they do not work for me (i.e. I am not capable enough in VBA to modify the macros suggested to my needs.

我已尝试过其他用户在此论坛和其他论坛中提出的类似挑战的其他解决方案,但它们对我不起作用(即我在VBA中无法根据我的需要修改建议的宏。

What I want is in the masterTable-sheet in the masterworkbook to have all the registration numbers of the cars in the first column and one record/car pr row, and based on this number, I want formulas/macros in column B that gets the cartype from A3 in all the separate workbooks, in column C I want a formula that gets the purchase date from A4 from all the workbooks.

我想要的是在masterworkbook中的masterTable表中,在第一列和一个记录/汽车pr行中包含汽车的所有注册号,并且基于这个数字,我想要B列中的公式/宏获得在所有单独的工作簿中来自A3的cartype,在CI列中想要一个公式,从所有工作簿中获取A4的购买日期。

Further I would, in the masterworkbook, like to have a SETUP sheet where I write the path to the directory i.e. c:/test so that it can be used in the formula/macro that is the solution on the above problem. Or if the path can be derived automatically from the directory in which the active masterworkbook is saved.

在masterworkbook中,我希望有一个SETUP表,我在其中编写目录的路径,即c:/ test,以便它可以在公式/宏中使用,这是上述问题的解决方案。或者,如果路径可以从保存活动masterworkbook的目录中自动导出。

Can anyone out there help me?

任何人都可以帮助我吗?

And please note that I am a novice in VBA and need it explained loud and clear ;)

请注意我是VBA的新手,需要大声清楚解释;)

Thank you in advance :)

先感谢您 :)

1 个解决方案

#1

yes, you can build a formula that will pull from another workbook. e.g. if your reg. no. is in A2, and your path is in Setup!A1 then a formula such as

是的,您可以构建一个将从另一个工作簿中提取的公式。例如如果你的注册。没有。在A2中,你的路径在Setup!A1然后是一个公式,如

=INDIRECT("'[" & Setup!A1 & A2 & ".xlsx]Summary'!B2")

will work - Note that INDIRECT will only work on open files, and the file will have to be open for the Indirect to update itself.

将起作用 - 请注意,INDIRECT仅适用于打开的文件,并且必须打开该文件才能让Indirect自行更新。

using a function like INDIRECT.EXT from morefunc.dll - install instructions here

从morefunc.dll使用像INDIRECT.EXT这样的函数 - 在这里安装说明

There is another Indirect function that someone has written, IndirecEx, that also does the same as the INDIRECT.EXT function but shows the source here: code shown to avoid link rot:

有人编写的另一个Indirect函数IndirecEx,它也和INDIRECT.EXT函数一样,但在这里显示源:显示的代码是为了避免链接腐烂:

'Credits:
'- Designed and written by Wilson So.
'- The 'CreateObject("Excel.Application")' trick was inspired by Harlan Grove's PULL function source code.
'------------------------------------
'This is an open source. You can freely redistribute and modify it, but please kindly give credit to the contributers.
'Please also kindly report any bugs/suggestions through e-mail or in the forums where I posted it.
'------------------------------------
'How to use:
'- Basically same as INDIRECT() in Excel - the same concept for the ref_text parameter.
'- To update the static memory for a particular reference,
'  type TRUE in the second parameter (just one of the IndirectEx() containing that reference)
'  and calculate it once.
'------------------------------------
'Features:
'- You can refer to the closed workbook data.
'- The retrieved closed workbook data will be stored in the static memory,
'  so in the next time, the closed workbook will not be opened again for fast retrieve.
'- A range instead of an array will be returned if the path is omitted in the ref_text,
'  so it still works fine if the user refers to an enormous array, e.g. "Sheet1!1:65536".
'- You can use it inside INDEX(), VLOOKUP(), MATCH() etc.
'- You can use it with OFFSET(), but only for opened workbook data.
'- The procedure will not blindly retrieve all the data as requested;
'  it will not retrieve data beyond the "Ctrl + End" cell, in order to keep the memory as small as possible.
'- #NUM! will be returned in case of lack of memory.
'- #REF! will be returned in case of a wrong path.
'- #VALUE! will be returned in case of other errors.
'------------------------------------
'Known issues:
'- Due to the use of SpecialCells(), #VALUE! will be returned if the worksheet for a closed workbook is protected.
'------------------------------------

Function IndirectEx(ref_text As String, Optional refresh_memory As Boolean = False) As Variant
    On Error GoTo ClearObject

    Dim RefName As String
    Dim SheetName As String
    Dim WBName As String
    Dim FolderName As String

    Dim vExcel As Object
    Dim vWB As Workbook

    Static dbOutput() As Variant
    Static dbKey() As String
    Static dbTotalOutput As Integer
    Dim dbIndex As Integer

    Dim UserEndRow As Long, UserEndCol As Integer
    Dim RealEndRow As Long, RealEndCol As Integer
    Dim EndRow As Long, EndCol As Integer
    Dim RangeHeight As Long, RangeWidth As Integer

    GetNames ref_text, RefName, SheetName, WBName, FolderName

    If dbTotalOutput = 0 Then
        ReDim dbOutput(1 To 1) As Variant
        ReDim dbKey(1 To 1) As String
    End If

    For i = 1 To dbTotalOutput
        If dbKey(i) = FolderName & WBName & "!" & SheetName & "!" & RefName Then
            dbIndex = i
        End If
    Next

    If dbIndex = 0 Or refresh_memory Then
        If dbIndex = 0 Then
            dbTotalOutput = dbTotalOutput + 1
            dbIndex = dbTotalOutput
            ReDim Preserve dbOutput(1 To dbTotalOutput) As Variant
            ReDim Preserve dbKey(1 To dbTotalOutput) As String
            dbKey(dbIndex) = FolderName & WBName & "!" & SheetName & "!" & RefName
        End If
        If FolderName = "" Then
            Set dbOutput(dbIndex) = Workbooks(WBName).Worksheets(SheetName).Range(RefName)
        ElseIf Dir(FolderName & WBName) <> "" Then
            Set vExcel = CreateObject("Excel.Application")
            Set vWB = vExcel.Workbooks.Open(FolderName & WBName)
            With vWB.Sheets(SheetName)
                On Error GoTo ClearObject
                UserEndRow = .Range(RefName).Row + .Range(RefName).Rows.Count - 1
                UserEndCol = .Range(RefName).Column + .Range(RefName).Columns.Count - 1
                RealEndRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
                RealEndCol = .Range("A1").SpecialCells(xlCellTypeLastCell).Column
                EndRow = IIf(UserEndRow < RealEndRow, UserEndRow, RealEndRow)
                EndCol = IIf(UserEndCol < RealEndCol, UserEndCol, RealEndCol)
                RangeHeight = EndRow - .Range(RefName).Row + 1
                RangeWidth = EndCol - .Range(RefName).Column + 1
                On Error Resume Next
                dbOutput(dbIndex) = .Range(RefName).Resize(RangeHeight, RangeWidth).Value
                If Err.Number <> 0 Then
                    IndirectEx = CVErr(xlErrNum)
                    GoTo ClearObject
                End If
            End With
            On Error GoTo ClearObject
            vWB.Close False
            vExcel.Quit
            Set vExcel = Nothing
        Else
            IndirectEx = CVErr(xlErrRef)
            Exit Function
        End If
    End If

    If TypeOf dbOutput(dbIndex) Is Range Then
        Set IndirectEx = dbOutput(dbIndex)
    Else
        IndirectEx = dbOutput(dbIndex)
    End If

    Exit Function

ClearObject:
    On Error Resume Next
    If Not (vExcel Is Nothing) Then
        vWB.Close False
        vExcel.Quit
        Set vExcel = Nothing
    End If
End Function

Private Sub GetNames(ByVal ref_text As String, ByRef RefName As String, ByRef SheetName As String, ByRef WBName As String, ByRef FolderName As String)
    Dim P_e As Integer
    Dim P_b1 As Integer
    Dim P_b2 As Integer
    Dim P_s As Integer

    P_e = InStr(1, ref_text, "!")
    P_b1 = InStr(1, ref_text, "[")
    P_b2 = InStr(1, ref_text, "]")
    P_s = InStr(1, ref_text, ":\")

    If P_e = 0 Then
        RefName = ref_text
    Else
        RefName = Right$(ref_text, Len(ref_text) - P_e)
    End If
    RefName = Replace$(RefName, "$", "")

    If P_e = 0 Then
        SheetName = Application.Caller.Parent.Name
    ElseIf P_b1 = 0 Then
        SheetName = Left$(ref_text, P_e - 1)
    Else
        SheetName = Mid$(ref_text, P_b2 + 1, P_e - P_b2 - 1)
    End If
    SheetName = Replace$(SheetName, "'", "")

    If P_b1 = 0 Then
        WBName = Application.Caller.Parent.Parent.Name
    Else
        WBName = Mid$(ref_text, P_b1 + 1, P_b2 - P_b1 - 1)
    End If

    If P_s = 0 Then
        FolderName = ""
    Else
        FolderName = Left$(ref_text, P_b1 - 1)
    End If
    If Left$(FolderName, 1) = "'" Then FolderName = Right$(FolderName, Len(FolderName) - 1)
End Sub