多工作簿多工作表数据查询

zhaobingznj

求帮助    如图所示
问题1.可以手动选择多个文件，然后手动选择要查询的数据和所在的列数，返回 数据所在行 和 文件名称
（自己新手，尝试做了一个汇总后筛选，怎么直接返回数据出来实在做不出来）






问题2.  怎么向第二个一样 一次能多个结果   



还有一个小小的要求 希望代码能有注释  

zhaobingznj

额 不是特别想用工具 想知道代码怎么写 自己懂了可以灵活运动

abc123281

仅供参考




多工作簿多工作表数据查询.rar (16.14 KB, 下载次数: 215)

2018-3-6 23:00 上传

点击文件名下载附件

wmqz.130

参考http://club.excelhome.net/thread-1399201-1-1.html

opiona

1.     Set SHX = Worksheets("Sheet3")
   
2.     SHX.Range("A5:Z65536").ClearContents
   
3.    
   
4.     Rem 全部文件
   
5.     FileArr = FileAllArr(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, True, False)
   
6.     For I = 0 To UBound(FileArr)
   
7.         
   
8.         Set WB = Workbooks.Open(FileArr(I))
   
9.         Str_coon = "HDR=yes';Data Source =" & FileArr(I)    '//OFFICE2003，2007 通用
   
10.         For Each SH In WB.Worksheets
    
11.             Rem  提示信息，在状态栏显示
    
12.             Application.StatusBar = "查询文件总数：" & UBound(FileArr) + 1 & " 当前是第：" & I + 1 & "  当前查询的文件是：" & GetPathFromFileName(FileArr(I), True) & "   正在查询的工作表是：" & SH.Name
    
13.             DoEvents
    
14.             Rem 判断是否是所需工作表
    
15.             If SHX.Range("B2").Value = SH.Range("A" & SHX.Range("B1").Value).Value Then
    
16.                 Rem 组合查询标题
    
17.                 StrSQL = "SELECT "
    
18.                 For ICOL = 1 To SHX.Range("AZ4").End(xlToLeft).Column
    
19.                     If ICOL > 1 Then StrSQL = StrSQL & ","
    
20.                     If SHX.Cells(4, ICOL).Value = "来自文件" Then
    
21.                         StrSQL = StrSQL & "'" & GetPathFromFileName(FileArr(I)) & "' AS  来自文件"
    
22.                     Else
    
23.                         StrSQL = StrSQL & SHX.Cells(4, ICOL).Value
    
24.                     End If
    
25.                 Next
    
26.                 Rem 查询条件
    
27.                 StrSQL = StrSQL & " FROM [" & SH.Name & "$A" & SHX.Range("B1").Value & ":AZ]"
    
28.                 If Len(SHX.Range("D1").Value) > 0 And Len(SHX.Range("D2").Value) > 0 Then
    
29.                     StrSQL = StrSQL & " WHERE INSTR(" & SHX.Range("D1").Value & ",'" & SHX.Range("D2").Value & "')>0"
    
30.                 End If
    
31.                
    
32.                 Rem 粘贴数据
    
33.                 IROW = SHX.Range("A65536").End(3).Row + 1
    
34.                 SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, False)
    
35.                 SHX.Range("A" & IROW).Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR '//（0 TO X)的数组行列都要+1，(1 TO X) 的不要
    
36.             End If
    
37.         Next
    
38.         WB.Close True  '//保存
    
39.     Next

复制代码

opiona

完整代码和设计见附件： 多工作簿多工作表数据查询.rar (413.17 KB, 下载次数: 213)

2018-3-7 11:47 上传

点击文件名下载附件

opiona

如果需要查询结果标题有变化，可自行编辑第四行标题

opiona

查询指定单元格：

1.     Set SHX = Worksheets("Sheet1")
   
2.     SHX.Range("A5:C65536").ClearContents
   
3.    
   
4.     Rem 全部文件
   
5.     FileArr = FileAllArr(ThisWorkbook.Path, "*.xls?", ThisWorkbook.Name, True, False)
   
6.     For I = 0 To UBound(FileArr)
   
7.         Set WB = Workbooks.Open(FileArr(I))
   
8.         For Each SH In WB.Worksheets
   
9.             Rem  提示信息，在状态栏显示
   
10.             Application.StatusBar = "查询文件总数：" & UBound(FileArr) + 1 & " 当前是第：" & I + 1 & "  当前查询的文件是：" & GetPathFromFileName(FileArr(I), True) & "   正在查询的工作表是：" & SH.Name
    
11.             DoEvents
    
12.             Rem 粘贴数据
    
13.             IROW = SHX.Range("A65536").End(3).Row + 1
    
14.             SHX.Cells(IROW, 1).Value = SH.Range(SHX.Range("B1").Value).Value
    
15.             SHX.Cells(IROW, 2).Value = SH.Name   '//工作表名
    
16.             SHX.Cells(IROW, 3).Value = GetPathFromFileName(FileArr(I)) '//来自文件"
    
17.         Next
    
18.         WB.Close False
    
19.     Next

复制代码