求大神帮助，如何把同一文件夹下所有表格中特定的一行提取到新表格中

漫了个小游

大神好，自己研究了好久，实在是研究不明白了，有没有办法把表格中设计评审表这个sheet的17行统计到汇总表中，在下面排起来，附件里只有这几个表，实际上可能会有几十个表。求大神帮忙，谢谢 谢谢！！！

漫了个小游

有没有老师们帮帮忙，谢谢啦

LMY123

漫了个小游 发表于 2018-8-7 13:13
有没有老师们帮帮忙，谢谢啦

1. 'http://club.excelhome.net/thread-1341555-1-1.html
   
2. Sub test()
   
3.   Dim cnn As Object, SQL As String, MyPath$, MyFile$, n As Long
   
4. '  Cells.Clear
   
5.   Set cnn = CreateObject("ADODB.Connection")
   
6.   MyPath = ThisWorkbook.Path & ""
   
7.   MyFile = Dir(MyPath & "*.xlsx")
   
8.   Do While MyFile <> ""
   
9.      If MyFile <> ThisWorkbook.Name Then
   
10.         n = n + 1
    
11.         If n = 1 Then
    
12.             cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & MyPath & MyFile
    
13.            SQL = "SELECT * FROM [设计评审表$A17:BO17] WHERE F1 IS NOT NULL"
    
14.         Else
    
15.            SQL = SQL & " UNION ALL SELECT * FROM [Excel 12.0;HDR=NO;Database=" & MyPath & MyFile & "].[设计评审表$A17:BO17] "
    
16.         End If
    
17.      End If
    
18.     MyFile = Dir()
    
19.   Loop
    
20.   Range("A4").CopyFromRecordset cnn.Execute(SQL)
    
21.   cnn.Close
    
22.   Set cnn = Nothing
    
23. End Sub

复制代码

漫了个小游

LMY123 发表于 2018-8-7 14:36

对象关闭时，不允许操作是什么意思

LMY123

漫了个小游 发表于 2018-8-7 19:57
对象关闭时，不允许操作是什么意思

MyPath = ThisWorkbook.Path & "/"

漫了个小游

LMY123 发表于 2018-8-7 20:45
MyPath = ThisWorkbook.Path & "/"

棒棒哒，十分感谢，十分感谢！！！

陆地鱼仙人掌

LMY123 发表于 2018-8-7 14:36

大神帮忙看看我的这个，非常感谢http://club.excelhome.net/thread-1455272-1-1.html

LMY123

陆地鱼仙人掌 发表于 2019-1-6 20:24
大神帮忙看看我的这个，非常感谢http://club.excelhome.net/thread-1455272-1-1.html

1. Sub 多行_多列_多条件_查询_ADO法_同夹_多薄_指定表_参考()
   
2.     时间 = Timer
   
3.     Range("A9:I65536").Clear
   
4.     Application.ScreenUpdating = False
   
5.     Dim objWMI As Object
   
6.     Const HKEY_LOCAL_MACHINE = &H80000002
   
7.     Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
   
8.     条件数组 = Range("A1:E7")
   
9.     For 行 = 1 To UBound(条件数组)
   
10.         If 条件数组(行, 2) <> "" Then 条件1 = 条件1 & " and " & 条件数组(行, 1) & "='" & 条件数组(行, 2) & "'"
    
11.         If 条件数组(行, 3) <> "" Then 条件2 = 条件2 & " and " & 条件数组(行, 1) & "='" & 条件数组(行, 3) & "'"
    
12.         If 条件数组(行, 4) <> "" Then 条件3 = 条件3 & " and " & 条件数组(行, 1) & "='" & 条件数组(行, 4) & "'"
    
13.         If 条件数组(行, 5) <> "" Then 条件4 = 条件4 & " and " & 条件数组(行, 1) & "='" & 条件数组(行, 5) & "'"
    
14.     Next 行
    
15.     If 条件1 & 条件2 & 条件3 & 条件4 = "" Then Exit Sub
    
16.     条件1 = Mid(条件1, 5): 条件2 = Mid(条件2, 5): 条件3 = Mid(条件3, 5): 条件4 = Mid(条件4, 5)
    
17.     If 条件4 = "" And 条件3 <> "" And 条件2 <> "" And 条件1 <> "" Then
    
18.         条件组合 = 条件1 & "Or" & (条件2) & "Or" & (条件3)
    
19.     ElseIf 条件4 = "" And 条件3 = "" And 条件2 <> "" And 条件1 <> "" Then
    
20.         条件组合 = 条件1 & "Or" & (条件2)
    
21.     ElseIf 条件4 = "" And 条件3 = "" And 条件2 = "" And 条件1 <> "" Then
    
22.         条件组合 = 条件1
    
23.     ElseIf 条件4 <> "" And 条件3 <> "" And 条件2 <> "" And 条件1 <> "" Then
    
24.         条件组合 = 条件1 & "Or" & (条件2) & "Or" & (条件3) & "Or" & (条件4)
    
25.     End If
    
26.     If Application.Version < 12 Then
    
27.         连接方式 = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='excel 8.0;imex=1';Data Source="
    
28.         objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 0
    
29.     Else
    
30.         连接方式 = "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='excel 12.0;imex=1';Data Source="
    
31.         objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Office" & Application.Version & "\Access Connectivity Engine\Engines\Excel", "TypeGuessRows", 0
    
32.     End If
    
33.     路径 = ThisWorkbook.Path & ""
    
34.     外薄 = Dir(路径 & "*.xls*")
    
35.     Do While 外薄 <> ""
    
36.         If InStr(外薄, ThisWorkbook.Name) = 0 Then
    
37.             Set 连接 = CreateObject("adodb.connection")
    
38.             连接.Open 连接方式 & 路径 & 外薄
    
39.             Set 记录 = 连接.OpenSchema(20)
    
40.             Do Until 记录.EOF
    
41.                 If 记录.Fields("TABLE_TYPE") = "TABLE" Then
    
42.                     外表 = Replace(记录("TABLE_NAME").Value, "'", "")
    
43.                     If Right(外表, 1) = "$" Then
    
44.                         Set rst = 连接.Execute("[" & 外表 & "a1:a]")
    
45.                         If Err.Number = 0 Then
    
46.                             If rst.Fields(0).Name = "字段1" Then
    
47.                                 SQL = "select 字段3,字段5,'" & Replace(外薄, ".xls", "") & "','" & Replace(外表, "$", "") & "' from [" & 外表 & "] where" & 条件组合
    
48.                                 Set rst = 连接.Execute(SQL)
    
49.                                 If Not rst.EOF Then Range("a65536").End(3).Offset(1).CopyFromRecordset rst
    
50.                             End If
    
51.                         Else
    
52.                             Err.Clear
    
53.                         End If
    
54.                     End If
    
55.                 End If
    
56.                 记录.MoveNext
    
57.             Loop
    
58.         End If
    
59.         外薄 = Dir()
    
60.     Loop
    
61.     记录.Close: Set 记录 = Nothing
    
62.     rst.Close: Set rst = Nothing
    
63.     连接.Close: Set 连接 = Nothing
    
64.     Application.ScreenUpdating = True
    
65.     MsgBox Timer - 时间
    
66. End Sub

复制代码

陆地鱼仙人掌

LMY123 发表于 2019-1-6 22:41

运行出错。运行时 错误424  要求对象。我要调整哪里吗？

LMY123

陆地鱼仙人掌 发表于 2019-1-6 22:53
运行出错。运行时 错误424  要求对象。我要调整哪里吗？

Sub 多行_多列_多条件_查询_ADO法_同夹_多薄_指定表_参考()
    时间 = Timer
    Range("A9:I65536").Clear
    Application.ScreenUpdating = False
    Dim objWMI As Object
    Const HKEY_LOCAL_MACHINE = &H80000002
    Set objWMI = GetObject("winmgmts:\\.\root\default:StdRegProv")
    条件数组 = Range("A1:E7")
    For 行 = 1 To UBound(条件数组)
        If 条件数组(行, 2) <> "" Then 条件1 = 条件1 & " and " & 条件数组(行, 1) & "='" & 条件数组(行, 2) & "'"
        If 条件数组(行, 3) <> "" Then 条件2 = 条件2 & " and " & 条件数组(行, 1) & "='" & 条件数组(行, 3) & "'"
        If 条件数组(行, 4) <> "" Then 条件3 = 条件3 & " and " & 条件数组(行, 1) & "='" & 条件数组(行, 4) & "'"
        If 条件数组(行, 5) <> "" Then 条件4 = 条件4 & " and " & 条件数组(行, 1) & "='" & 条件数组(行, 5) & "'"
    Next 行
    If 条件1 & 条件2 & 条件3 & 条件4 = "" Then Exit Sub
    条件1 = Mid(条件1, 5): 条件2 = Mid(条件2, 5): 条件3 = Mid(条件3, 5): 条件4 = Mid(条件4, 5)
    If 条件4 = "" And 条件3 <> "" And 条件2 <> "" And 条件1 <> "" Then
        条件组合 = 条件1 & "Or" & (条件2) & "Or" & (条件3)
    ElseIf 条件4 = "" And 条件3 = "" And 条件2 <> "" And 条件1 <> "" Then
        条件组合 = 条件1 & "Or" & (条件2)
    ElseIf 条件4 = "" And 条件3 = "" And 条件2 = "" And 条件1 <> "" Then
        条件组合 = 条件1
    ElseIf 条件4 <> "" And 条件3 <> "" And 条件2 <> "" And 条件1 <> "" Then
        条件组合 = 条件1 & "Or" & (条件2) & "Or" & (条件3) & "Or" & (条件4)
    End If
    If Application.Version < 12 Then
        连接方式 = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties='excel 8.0;imex=1';Data Source="
        objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel", "TypeGuessRows", 0
    Else
        连接方式 = "Provider=Microsoft.ace.OLEDB.12.0;Extended Properties='excel 12.0;imex=1';Data Source="
        objWMI.SetDWORDValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Office\" & Application.Version & "\Access Connectivity Engine\Engines\Excel", "TypeGuessRows", 0
    End If
    路径 = ThisWorkbook.Path & "\"
    外薄 = Dir(路径 & "*.xls*")
    Do While 外薄 <> ""
        If InStr(外薄, ThisWorkbook.Name) = 0 Then
            Set 连接 = CreateObject("adodb.connection")
            连接.Open 连接方式 & 路径 & 外薄
            Set 记录 = 连接.OpenSchema(20)
            Do Until 记录.EOF
                If 记录.Fields("TABLE_TYPE") = "TABLE" Then
                    外表 = Replace(记录("TABLE_NAME").Value, "'", "")
                    If Right(外表, 1) = "$" Then
                        Set rst = 连接.Execute("[" & 外表 & "a1:a]")
                        If Err.Number = 0 Then
                            If rst.Fields(0).Name = "字段1" Then
                                Sql = "select 字段3,字段5,'" & Replace(外薄, ".xls", "") & "','" & Replace(外表, "$", "") & "' from [" & 外表 & "] where" & 条件组合
                                Set rst = 连接.Execute(Sql)
                                If Not rst.EOF Then Range("a65536").End(3).Offset(1).CopyFromRecordset rst
                            End If
                        Else
                            Err.Clear
                        End If
                    End If
                End If
                记录.MoveNext
            Loop
        End If
        外薄 = Dir()
    Loop
    记录.Close: Set 记录 = Nothing
    rst.Close: Set rst = Nothing
    连接.Close: Set 连接 = Nothing
    Application.ScreenUpdating = True
    MsgBox Timer - 时间
End Sub