ACCESS表格从纵向转横向的查询求助

cnlikai

因数据量比较大，需要使用Access数据库建立一些统计信息，现在需要使用查询的方式把统计信息从纵向转为横向，需要达到如图所示的效果，请各位老师予以指点，万分感谢！

xiangbaoan

1. Sub test()
   
2.   Dim Cn As Object, Rs As Object, Dict As Object, Sq As String
   
3.   Dim ar, j As Long, r As Long, c As Long, x As Long, y As Long
   
4.   Set Dict = CreateObject("Scripting.Dictionary")
   
5.   Set Cn = CreateObject("ADODB.Connection")
   
6.   Set Rs = CreateObject("ADODB.Recordset")
   
7.   Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\示例.accdb"
   
8.   Sq = "SELECT 简称,号码 FROM 示例"
   
9.   Rs.Open Sq, Cn, 1, 3
   
10.   ar = Rs.GetRows()
    
11.   ReDim br(1 To UBound(ar, 2) + 1, 1 To UBound(ar, 2) + 1) As String
    
12.   c = 1: br(1, 1) = "简称": br(2, 1) = "号码"
    
13.   For j = 0 To UBound(ar, 2)
    
14.     If Not Dict.Exists(ar(0, j)) Then
    
15.       c = c + 1
    
16.       br(1, c) = ar(0, j)
    
17.       br(2, c) = ar(1, j)
    
18.       Dict(ar(0, j)) = Array(3, c)
    
19.     Else
    
20.       y = Dict(ar(0, j))(0)
    
21.       x = Dict(ar(0, j))(1)
    
22.       br(y, x) = ar(1, j)
    
23.       Dict(ar(0, j)) = Array(y + 1, x)
    
24.       If y > r Then r = y: br(y, 1) = "号码"
    
25.     End If
    
26.   Next
    
27.   Range("A1").Resize(r, c) = br
    
28.   Rs.Close: Cn.Close: Set Rs = Nothing: Set Cn = Nothing: Set Dict = Nothing: Beep
    
29. End Sub

复制代码

xiangbaoan

示例.rar (32.2 KB, 下载次数: 11)

2021-8-23 20:59 上传

点击文件名下载附件

鑫尼达

你的效果里面,月份哪去了?还有,重复的咋处理?

cnlikai

鑫尼达 发表于 2021-8-23 21:09
你的效果里面,月份哪去了?还有,重复的咋处理?

老师，不需要显示月份，不存在重复项，号码是主键

cnlikai

xiangbaoan 发表于 2021-8-23 20:59

老师，这个能直接在ACCESS里面实现嘛？

xiangbaoan

cnlikai 发表于 2021-8-23 21:28
老师，这个能直接在ACCESS里面实现嘛？

再弄回去就可以了。

cnlikai

xiangbaoan 发表于 2021-8-23 21:41
再弄回去就可以了。

您如果方便的话能指点一下怎么做嘛，自己VBA会的有限，谢谢！

鑫尼达

这问题看着简单,感觉难度还不小啊.不过你为啥要搞成这样,而且还搞到access里面去.最后这样子搞到access里面之后,就符合规范的表了.

xiangbaoan

1. Option Explicit
   
2. 
   
3. Dim Cnn As New ADODB.Connection, Cmd As New ADODB.Command, Cat As New ADOX.Catalog
   
4. 
   
5. Sub IntoAccess()
   
6.   Dim f As String
   
7.   f = ThisWorkbook.Path & "\示例2.accdb"
   
8.   
   
9.   UpdateAddRecords f
   
10.    
    
11.   MsgBox "O的K!", 64
    
12. End Sub
    
13. 
    
14. Function UpdateAddRecords(f As String)
    
15.   Dim tb As String, Sql As String, ar
    
16.   ar = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Range("A1").CurrentRegion.Resize(1)))
    
17.   tb = "我的示例表"
    
18.   If Len(Dir(f)) = 0 Then CreateAccessDatabase Join(ar), f, tb
    
19.   Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & f
    
20.   Sql = "SELECT * FROM [Excel 12.0;DataBase=" & ActiveWorkbook.FullName & "].[" & ActiveSheet.Name & "$" & _
    
21.     Range("A1").CurrentRegion.Address(0, 0) & "]"
    
22.   Sql = "INSERT INTO " & tb & " " & Sql
    
23.   Cnn.Execute Sql
    
24.   Cnn.Close: Set Cnn = Nothing
    
25. End Function
    
26. 
    
27. Function CreateAccessDatabase(Tit As String, Dbf As String, Tbl As String)
    
28.   Dim ar, j As Long, Sql As String
    
29.   ar = Split(Tit)
    
30.   For j = 0 To UBound(ar)
    
31.     Sql = Sql & ",[" & ar(j) & "] Text(255)"
    
32.   Next
    
33.   Sql = "CREATE TABLE " & Tbl & "(" & Mid(Sql, 2) & ")"
    
34.   Cat.Create "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Dbf
    
35.   Set Cmd.ActiveConnection = Cat.ActiveConnection
    
36.   With Cmd
    
37.     .CommandText = Sql
    
38.     .Execute , , adCmdText
    
39.   End With
    
40.   Set Cmd = Nothing: Set Cat = Nothing
    
41. End Function

复制代码