当前位置：首页>Excel>Excel跨多工作簿多工作表查询数据,这个方法更高效!

Excel跨多工作簿多工作表查询数据,这个方法更高效!

2026-05-11 19:47:59

点亮☆星标，不错过精彩分享

如何从8个工作簿70多个工作表中查询出某个编号的物料数据呢？

这里有8个供应商数据表，每个供应商工作簿中有N个工作表，现需要根据某个物料编号，在这些表中查询出所有记录。

这种跨文件跨工作表的查询，方法有很多种，比如，用VSTACK+FILTER函数、用power query等。

但都比较麻烦，因为文件数量太多，工作簿数量不定，工作表数量不确定！

如果要手动操作，一般逻辑是这样的：需要先将这么多个数据文件，几十上百个工作中的数据先合并到一个工作表中，再用FILTER函数筛选出来。

如果只有三两个表还好，但如果有几十上百个工作表，几百上千个物料编号，手动用函数公式筛选查询，查一次可能要一个小时。

如果是要给老板或领导做的表，他们可能不会这么复杂的操作，难道你还得教他怎么写函数公式？如果这样做，老板明天就能让你放长假了。

今天我们分享一个VBA查询工具，只需要输入要查询的编号，点一下按钮几秒钟就能从几十个表中把数据查询汇总出来，【VBA代码在文章最后】。

我们演示一下，在这里输入要查询的物料编号，点一下查询按钮，选择所有查询数据源表。

确定，几秒钟时间，就能从75个工作表中，把这个编号的物料数据全部查询筛选出来。

还能把数据的来源路径一一标注清楚，方便备查。

动画演示：

不会VBA，需要这个查询表的小伙伴，关注公众号，回复消息私信：跨表查询，可下载。

VBA代码：

Private Sub CommandButton1_Click()Dim fileNames As VariantDim i%, j%, xc As Worksheet, startrow%Dim wb As WorkbookDim ws As WorksheetDim lastRow As LongDim arr, brr, findid$Application.ScreenUpdating = FalseSet xc = ThisWorkbook.ActiveSheetWith xc    findid = .[h1]    If Len(findid) = 0 Then        MsgBox "H1查询色号为空，请输入要查询的色号"        End    End If    If InStr(1, .[g1], "查询") = 0 Then        MsgBox "请点到数据查询表再运行"        End    End If    startrow = .Range("a50000").End(xlUp).Row    .Range("a3:e" & startrow + 3).Clear    startrow = 3    fileNames = Application.GetOpenFilename( _        FileFilter:="Excel Files (*.xlsx; *.xlsm; *.xls), *.xlsx; *.xlsm; *.xls", _        Title:="选择Excel文件", _        MultiSelect:=True)    If IsArray(fileNames) Then ' 检查是否选择了文件        For i = LBound(fileNames) To UBound(fileNames)            Set wb = Workbooks.Open(fileNames(i))            If ThisWorkbook.Name = wb.Name Then                wb.Close SaveChanges:=False                Set wb = Nothing                GoTo 下一文件            End If            For Each ws In wb.Worksheets                lastRow = ws.Range("a50000").End(xlUp).Row                arr = ws.Range("a2:a" & lastRow + 1)                For j = 1 To UBound(arr)                    If arr(j, 1) = findid Then                        brr = ws.Range("a" & j + 1 & ":d" & j + 1)                        .Range("a" & startrow).Resize(1, 4) = brr                        .Range("e" & startrow) = GetFileNameWithoutExt(wb.Name) & "\" & ws.Name & "\" & j + 1                        startrow = startrow + 1                    End If                Next j            Next ws            wb.Close SaveChanges:=False            Set wb = Nothing下一文件:        Next i        Application.ScreenUpdating = True        With .Range("a1:e" & startrow - 1)            .Borders.LineStyle = xlContinuous '边框            .HorizontalAlignment = xlCenter '居中            .VerticalAlignment = xlCenter '垂直居中        End With        MsgBox "查询完成！", vbInformation    Else ' 未选择文件时的提示        Application.ScreenUpdating = True        MsgBox "未选择文件", vbExclamation        Exit Sub    End IfEnd WithEnd SubFunction GetFileNameWithoutExt(filePath As String) As String    Dim fso As Object    Dim fileName As String    Set fso = CreateObject("Scripting.FileSystemObject")    fileName = fso.GetBaseName(filePath)    GetFileNameWithoutExt = fileName    Set fso = NothingEnd Function