提取簿内各表A列不重复值和表名，写入对应B列数据

jjmysjg

提取工作簿内各表A列不重复值到汇总表A列，
提取各工作表名到第一行，
各表B列数据写入汇总表。
附件是样表，实际数据有40多个表，每个表有3000以上的行。
谢谢各位老师！

jjmysjg

照搬了以前的代码，没有成功。

jiminyanyan

jjmysjg 发表于 2018-7-18 12:52
照搬了以前的代码，没有成功。

黄色的地方搞个双字典，2个字典。

opiona

自动适应50个表应该没有问题

1.     Set SHX = Worksheets("汇总")
   
2.     Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
   
3.     StrBT = ""
   
4.     StrSH = ""
   
5.     For Each SH In Worksheets
   
6.         If SH.Name <> SHX.Name Then
   
7.             If StrSH <> "" Then StrSH = StrSH & ","
   
8.             StrSH = StrSH & SH.Name
   
9.             If StrBT <> "" Then StrBT = StrBT & " UNION ALL "
   
10.             StrBT = StrBT & "SELECT '" & SH.Name & "' AS 表名"
    
11.             StrBT = StrBT & ",行政区划代码,行政区划名称"
    
12.             StrBT = StrBT & " FROM [" & SH.Name & "$]"
    
13.             StrBT = StrBT & " WHERE NOT 行政区划代码 IS NULL AND LEN(行政区划代码)>0"
    
14.         End If
    
15.     Next
    
16.    
    
17.     StrSQL = ""
    
18.     StrSQL = StrSQL & "TRANSFORM MAX(行政区划名称)"
    
19.     StrSQL = StrSQL & " SELECT 行政区划代码 AS 代码 FROM (" & StrBT & ")"
    
20.     StrSQL = StrSQL & " GROUP BY 行政区划代码"
    
21.     StrSQL = StrSQL & " PIVOT 表名"
    
22.     StrSQL = StrSQL & " IN (" & StrSH & ")"
    
23.     SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, True)
    
24.     SHX.Cells.ClearContents
    
25.     SHX.Range("A1").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR

复制代码

opiona

使用的是：SQL的TRANSFORM
现在加了一个表： QQ14885553.rar (30.92 KB, 下载次数: 17)

2018-7-18 14:25 上传

点击文件名下载附件

jjmysjg

opiona 发表于 2018-7-18 14:26
使用的是：SQL的TRANSFORM
现在加了一个表：

谢谢
工作表名为数字与文本混时，RS.Open StrSQL, CN, 1, 3不能运行
比如工作表名为2018年6月，

opiona

jjmysjg 发表于 2018-7-18 14:47
谢谢
工作表名为数字与文本混时，RS.Open StrSQL, CN, 1, 3不能运行
比如工作表名为2018年6月，

不知道为什么

jjmysjg 发表于 2018-7-18 14:47
谢谢
工作表名为数字与文本混时，RS.Open StrSQL, CN, 1, 3不能运行
比如工作表名为2018年6月，

字典和数组方法，如图

不知道为什么

jjmysjg 发表于 2018-7-18 14:47
谢谢
工作表名为数字与文本混时，RS.Open StrSQL, CN, 1, 3不能运行
比如工作表名为2018年6月，

代码

杨宝明

针对你的附件中的表，我试着编了一段代码，因为也是初学，可能会有很多不严谨的地方，仅做参考，不知道能否满足要求。

1. Sub zz()
   
2. Dim m, n, r, i, str As String
   
3. Dim ar, br(1 To 1000, 1 To 50)
   
4. Dim d1 As Object, d2 As Object
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. For Each sht In Sheets
   
8.     If sht.Name <> "汇总" Then
   
9.         n = n + 1
   
10.         d2(sht.Name) = n
    
11.         With sht
    
12.             r = .Cells(Rows.Count, 1).End(xlUp).Row
    
13.             ar = .Range("a2:b" & r)
    
14.         End With
    
15.         For i = 1 To UBound(ar)
    
16.             If Not d1.exists(ar(i, 1)) Then
    
17.                 m = m + 1
    
18.                 d1(ar(i, 1)) = m
    
19.                 br(m, n) = ar(i, 2)
    
20.             Else
    
21.                 br(d1(ar(i, 1)), n) = ar(i, 2)
    
22.             End If
    
23.         Next i
    
24.     End If
    
25. Next
    
26. Sheets("汇总").[a2].Resize(m, 1) = Application.Transpose(d1.keys())
    
27. Sheets("汇总").[b1].Resize(1, n) = d2.keys()
    
28. Sheets("汇总").[b2].Resize(m, n) = br
    
29. End Sub

复制代码