动态提取数据（顺序不管）2（）请教高手修改代码）

zuoxingfa

在蓝桥老师的帮我写的代码上自己修改了一下，加了循环工作表的提取。但还是有问题。问题一：只能提取工作表1的，有几个工作表就循环了几次，也提取了几次。其他工作表的没有提取到。
问题二：在v列加上提取工作簿名w列上提取工作表名，不能按照提取的行数对应填写，只能按照提取的次数填写。
希望达到的目的：把所有的工作表都提取完，并按提取的行数对应添加工作簿名和工作表名。

       谢谢！！

2E-er

Sub 汇总2()

   Dim Wbk As Workbook, Fn$, myPath$, cnn, k&, Sht As Worksheet
   Dim st As Worksheet
   Dim s, t$, Sql$
   Set Sht = Sheet1
   Sht.Activate
   myPath = ThisWorkbook.Path & "/"
   Fn = Dir(myPath & "*.xl*")
   Application.ScreenUpdating = False
   s = "[" & Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose([B7:U7])), "],[") & "]"
   [B8:U65536] = ""
   [v1:w65536] = ""
   Do While Fn <> ""
       If Fn <> ThisWorkbook.Name Then
          Set Wbk = Workbooks.Open(myPath & Fn)
          With Wbk
             For Each st In Sheets
                With st
                    For k = 8 To Sht.Range("a65536").End(xlUp).Row
                        t = Sht.Range("a" & k).Value
                        If Len(t) Then
                        c = st.Name
                            Set cnn = CreateObject("ADODB.Connection")
                                cnn.Open "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source=" & myPath & Fn
                                Sql = "SELECT " & s & " FROM [" & c & "$a2:x] WHERE 姓名 ='" & t & "'"
                                Sht.Range("b65536").End(xlUp)(2).CopyFromRecordset cnn.Execute(Sql)
                                Sht.Range("v65536").End(xlUp)(2) = Fn
                                Sht.Range("w65536").End(xlUp)(2) = st.Name
                                cnn.Close
                            Set cnn = Nothing
                        Else
                             MsgBox "无提取人！", 64
                        End If
                    Next
               
                End With
                 Next
                Application.DisplayAlerts = False
                .Close False
                Application.DisplayAlerts = True
            End With
        End If
        Fn = Dir
  Loop
   Application.ScreenUpdating = True
End Sub

2E-er

[&a:x]这种写法默认只执行第一个表

zuoxingfa

谢谢指点。非常给力。能否解决一下问题二。就是把图一改成图二（按提取行数添加工作表明和工作簿名）。