需要从多表时取得需求的数据填至新表格

汪华

各位大神，取数时行，列的内容会跟据附表调整

LIUZHU

附件都不大，为什么打开却很卡？

LIUZHU

这个分页预览是不是打开特别卡？

LIUZHU

打开工作簿很卡

baofa2

1. Sub test1() '练习，仅供测试……
   
2.   
   
3.   ActiveSheet.UsedRange.Offset(1).Clear
   
4.   Application.ScreenUpdating = False
   
5.   
   
6.   Dim p As String, f As String
   
7.   Dim ar, br, dic As Object, dict As Object, target As Range
   
8.   Dim Conn As Object, rs As Object, Cata As Object, tb As Object
   
9.   Dim strConn As String, SQL As String, s As String, t As String, n As String, i As Long
   
10.   
    
11.   Set target = Range("A2")
    
12.   Set dic = CreateObject("Scripting.Dictionary")
    
13.   Set dict = CreateObject("Scripting.Dictionary")
    
14.   Set Cata = CreateObject("ADOX.Catalog")
    
15.   Set Conn = CreateObject("ADODB.Connection")
    
16.   
    
17.   ar = Application.Rept(Range("A1").CurrentRegion.Rows(1).Value, 1)
    
18.   For i = 1 To UBound(ar)
    
19.     s = "`" & Trim(ar(i)) & "`"
    
20.     dic.Add s, i
    
21.     ar(i) = "NULL AS " & s
    
22.   Next
    
23.   
    
24.   s = "Excel 12.0;HDR=YES;IMEX=1;Database="
    
25.   If Application.Version < 12 Then
    
26.     s = Replace(s, "12.0", "8.0")
    
27.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
    
28.   Else
    
29.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
    
30.   End If
    
31.   Conn.Open strConn & ThisWorkbook.FullName
    
32.   
    
33.   p = ThisWorkbook.Path & "\"
    
34.   f = Dir(p & "*.xls*")
    
35.   While Len(f)
    
36.     If p & f <> ThisWorkbook.FullName Then
    
37.       Cata.ActiveConnection = strConn & p & f
    
38.       For Each tb In Cata.Tables
    
39.         If tb.Type = "TABLE" Then
    
40.           t = Replace(tb.Name, "'", vbNullString)
    
41.           If Right(t, 1) = "$" Then
    
42.             br = ar
    
43.             SQL = "SELECT * FROM [" & s & p & f & "].[" & t & "A6:AA6] WHERE FALSE"
    
44.             Set rs = Conn.Execute(SQL)
    
45.             For i = 0 To rs.Fields.Count - 1
    
46.               n = "`" & rs.Fields(i).Name & "`"
    
47.               If dic.Exists(n) Then br(dic(n)) = n
    
48.             Next
    
49.             br(1) = Replace(br(1), "NULL", "'" & Replace(Split(t, "202")(0), "发货清单，", "") & "'")
    
50.             SQL = "SELECT " & Join(br, ",") & " FROM [" & s & p & f & "].[" & t & "A6:AA] WHERE LEN(石种)>0"
    
51.             dict.Add SQL, vbNullString
    
52.             If dict.Count = 49 Then
    
53.               target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
    
54.               Set target = Range("A" & Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1)
    
55.               dict.RemoveAll
    
56.             End If
    
57.             'Exit For
    
58.           End If
    
59.         End If
    
60.       Next
    
61.     End If
    
62.     f = Dir
    
63.   Wend
    
64.   If dict.Count Then target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
    
65.   
    
66.   With Range("A1").CurrentRegion
    
67.     .Borders.LineStyle = xlContinuous
    
68.     .HorizontalAlignment = xlCenter
    
69.     .Font.Name = "微软雅黑"
    
70.     .Font.Size = 10
    
71.     .Value = .Value
    
72.   End With
    
73.   
    
74.   rs.Close
    
75.   Set rs = Nothing
    
76.   Conn.Close
    
77.   Set Conn = Nothing
    
78.   Set Cata = Nothing
    
79.   Set target = Nothing
    
80.   Set dic = Nothing
    
81.   Set dict = Nothing
    
82.   Application.ScreenUpdating = True
    
83.   Beep
    
84. End Sub

复制代码

汪华

baofa2 发表于 2024-4-15 20:04

baofa2

汪华 发表于 2024-4-17 10:13

需要出问题的附件。

楼下附件……


楼下附件并无不妥测试成功.zip (292.67 KB, 下载次数: 11)

2024-4-17 10:33 上传

点击文件名下载附件

1. Option Explicit
   
2. 
   
3. '哎，随便更改表名及工作表数量…… 适用于 11F 附件
   
4. 
   
5. Sub test1() '无花，真不愿占用新楼层，但愿你能看到……
   
6.   
   
7.   ActiveSheet.UsedRange.Offset(1).Clear
   
8.   Application.ScreenUpdating = False
   
9.   
   
10.   Dim p As String, f As String
    
11.   Dim ar, br, dic As Object, dict As Object, target As Range
    
12.   Dim Conn As Object, rs As Object, Cata As Object, tb As Object, str_ As String
    
13.   Dim strConn As String, SQL As String, s As String, t As String, n As String, i As Long
    
14.   
    
15.   Set target = Range("A2")
    
16.   Set dic = CreateObject("Scripting.Dictionary")
    
17.   Set dict = CreateObject("Scripting.Dictionary")
    
18.   Set Cata = CreateObject("ADOX.Catalog")
    
19.   Set Conn = CreateObject("ADODB.Connection")
    
20.   
    
21.   ar = Application.Rept(Range("A1").CurrentRegion.Rows(1).Value, 1)
    
22.   For i = 1 To UBound(ar)
    
23.     s = "`" & Trim(ar(i)) & "`"
    
24.     dic.Add s, i
    
25.     ar(i) = "NULL AS " & s
    
26.   Next
    
27.   
    
28.   s = "Excel 12.0;HDR=YES;IMEX=1;Database="
    
29.   If Application.Version < 12 Then
    
30.     s = Replace(s, "12.0", "8.0")
    
31.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
    
32.   Else
    
33.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
    
34.   End If
    
35.   Conn.Open strConn & ThisWorkbook.FullName
    
36.   
    
37.   p = ThisWorkbook.Path & "\"
    
38.   f = Dir(p & "*.xls*")
    
39.   While Len(f)
    
40.     If p & f <> ThisWorkbook.FullName Then
    
41.       str_ = ""
    
42.       If InStr(f, "发货清单，") Then str_ = Replace(Split(f, "202")(0), "发货清单，", "")
    
43.       Cata.ActiveConnection = strConn & p & f
    
44.       For Each tb In Cata.Tables
    
45.         If tb.Type = "TABLE" Then
    
46.           t = Replace(tb.Name, "'", vbNullString)
    
47.           If Right(t, 1) = "$" Then
    
48.             If InStr(t, "发货清单") Then
    
49.               br = ar
    
50.               SQL = "SELECT * FROM [" & s & p & f & "].[" & t & "A6:AA6] WHERE FALSE"
    
51.               Set rs = Conn.Execute(SQL)
    
52.               For i = 0 To rs.Fields.Count - 1
    
53.                 n = "`" & rs.Fields(i).Name & "`"
    
54.                 If dic.Exists(n) Then br(dic(n)) = n
    
55.               Next
    
56.               If str_ = "" Then str_ = Replace(Split(t, "202")(0), "发货清单，", "")
    
57.               br(1) = Replace(br(1), "NULL", "'" & str_ & "'")
    
58.               SQL = "SELECT " & Join(br, ",") & " FROM [" & s & p & f & "].[" & t & "A6:AA] WHERE LEN(石种)>0"
    
59.               dict.Add SQL, vbNullString
    
60.               If dict.Count = 49 Then
    
61.                 target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
    
62.                 Set target = Range("A" & Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1)
    
63.                 dict.RemoveAll
    
64.               End If
    
65.               'Exit For
    
66.             End If
    
67.           End If
    
68.         End If
    
69.       Next
    
70.     End If
    
71.     f = Dir
    
72.   Wend
    
73.   If dict.Count Then target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
    
74.   
    
75.   With Range("A1").CurrentRegion
    
76.     .Borders.LineStyle = xlContinuous
    
77.     .HorizontalAlignment = xlCenter
    
78.     .Font.Name = "微软雅黑"
    
79.     .Font.Size = 10
    
80.     .Value = .Value
    
81.   End With
    
82.   
    
83.   rs.Close
    
84.   Set rs = Nothing
    
85.   Conn.Close
    
86.   Set Conn = Nothing
    
87.   Set Cata = Nothing
    
88.   Set target = Nothing
    
89.   Set dic = Nothing
    
90.   Set dict = Nothing
    
91.   Application.ScreenUpdating = True
    
92.   Beep
    
93. End Sub

复制代码

汪华

我重新上传一下，麻烦各位看看，是不是还是打开很卡。

tanglf188

汪华 发表于 2024-4-17 10:13

那是数据不规范，同一列有不同的数据类型

xlqsxl

我来参与一下，我用工具给你提了一下数据，你看是否可以：


工具中需要设置的参数：


工具介绍： https://club.excelhome.net/threa ... tml?_dsign=e20fcbc2