将多个工作薄中的一行报到到另一个工作薄中

一江云后

走过路过的大神，您好！
如附件中所述，计划将多个工作薄中的某一行全部提取到新建的工作薄中，请问该如何操作（实际不止两个工作薄，因为附件限制大小，所以只搞了两个）
自己折腾了好久，也查阅了一些资料，也在这看了些帖，无奈实在太菜了，还是没弄好，求大神伸出援助之手，不胜感激！

xiangbaoan

Option Explicit
Sub test()
Dim Cn As Object, Rs As Object, p$, f$, Sq$, k%, i%
Cells.ClearContents
Application.ScreenUpdating = False
Set Cn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        Sq = "SELECT * FROM [Excel 12.0;Database=" & p & f & "].[$A1:DJ] WHERE 代码=157"
        Rs.Open Sq, Cn, 1, 3
        k = k + 1
        If k = 1 Then
            For i = 0 To Rs.Fields.Count - 1
                [a1].Offset(0, i) = Rs.Fields(i).Name
            Next
        End If
        Cells(k + 1, 1).CopyFromRecordset Rs
        If Rs.State = 1 Then Rs.Close
    End If
    f = Dir
Loop
Cn.Close
Set Cn = Nothing
Set Rs = Nothing
Application.ScreenUpdating = True
End Sub

xiangbaoan

………………

一江云后

xiangbaoan 发表于 2019-11-7 06:53
………………

xiangbaoan大神

太谢谢你了，真厉害！！！

一江云后

xiangbaoan 发表于 2019-11-7 06:53
………………

xiaobaoan 大神 您好！
又碰到点问题，麻烦您有空给瞧睢
就是在您提供的文件夹中，一点问题都没有
但是我将您提供的文件夹中的“新建XLSX工作表”切到如附件图片1中的位置时，打开文件占地按钮时出现图片2 的错误提示，点调试后出现图片3的情况
请问这个问题能解决吗？

xiangbaoan

一江云后 发表于 2019-11-11 22:48
xiaobaoan 大神 您好！
又碰到点问题，麻烦您有空给瞧睢
就是在您提供的文件夹中，一点问题都没有

给我图片，我能看懂什么呢，猜一下，把157用西文的单引号引起来，如  ='157'

一江云后

xiangbaoan 发表于 2019-11-12 08:39
给我图片，我能看懂什么呢，猜一下，把157用西文的单引号引起来，如  ='157'

xingbaoan 大神 您好！
已经搞明白了，不是公式里有问题，是表里面有些157前面有000157
谢谢你啊！

xiangbaoan

一江云后 发表于 2019-11-14 22:16
xingbaoan 大神 您好！
已经搞明白了，不是公式里有问题，是表里面有些157前面有000157
谢谢你啊！

'名称 中联重科 都有吧?那就换成这样：
Sq = "SELECT * FROM [Excel 12.0;Database=" & p & f & "].[$A1:DJ] WHERE 名称='中联重科'"

cui26896

这样的汇总用处不大，市场的方向在控制的人，不取决于某个个体。

一江云后

xiangbaoan 发表于 2019-11-15 09:17
'名称 中联重科 都有吧?那就换成这样：
Sq = "SELECT * FROM [Excel 12.0;Database=" & p & f & "].[$A1 ...

好的，谢谢您！