如何用VBA代码，实现一维表转换成二维表

星梦月缘 · 发表于 2024-6-27 23:07

老师好，Excel中实现一维表转换成二维表，可以直接使用PQ中的透视方法快速进行转换，那么如果用VBA代码该如何实现呢？是不是需要双层字典的嵌套才能实现？
注意，产品和区域都的数量都是变量，后期都可以随时增加减少？

ykcbf1100 · 发表于 2024-6-28 06:57

参与一下，字典+数组

wang-way · 发表于 2024-6-28 00:16

方法有很多
1.sql transform pivot 法
2.两个字典棋盘法
3.嵌套字典法

taller · 发表于 2024-6-28 00:34

huarong7984 · 发表于 2024-6-28 05:32

此类实例论坛很多，搜一搜

今铭昔 · 发表于 2024-6-28 06:40

ykcbf1100 · 发表于 2024-6-28 07:00

参与一下。。。

Sub ykcbf() '//2024.6.28
Dim arr, brr, d
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
arr = Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 100)
m = 1: n = 1
brr(1, 1) = arr(1, 2)
For i = 2 To UBound(arr)
s = arr(i, 2)
If Not d.Exists(s) Then
m = m + 1
d(s) = m
brr(m, 1) = s
End If
r = d(arr(i, 2))
s = arr(i, 1)
If Not d.Exists(s) Then
n = n + 1
d(s) = n
brr(1, n) = s
End If
c = d(arr(i, 1))
brr(r, c) = arr(i, 3)
Next
[h1:z1000] = ""
[h1].Resize(m, n) = brr
[h1].Resize(1, n).Interior.Color = 49407
[h1].Resize(m, n).Borders.LineStyle = 1
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

wang-way · 发表于 2024-6-28 08:09

Sub SQL法()
Set wb = Application.ThisWorkbook
DataPath = wb.FullName
Dim DATA_ENGINE As String
Select Case Application.Version * 1
Case Is <= 11
DATA_ENGINE = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES;IMEX=2';Data Source="
Case Is >= 12
DATA_ENGINE = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=2'; Data Source= "
End Select
Set CNN = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.RecordSet")
CNN.Open DATA_ENGINE & DataPath
With ThisWorkbook.Worksheets(1)
EndRow = .Cells(.Cells.Rows.Count, 2).End(xlUp).Row
'SQL 查询
Sql = "Transform sum(金额) select 区域 from [Sheet1$A1:C] Where 产品 is not null Group by 区域 pivot 产品"
Set rs = CNN.Execute(Sql)
For j = 1 To rs.Fields.Count
Cells(8, j + 7).Value = rs.Fields(j - 1).Name
Next j
.Range("h9").CopyFromRecordset rs
End With
rs.Close
CNN.Close
Set wb = Nothing
Set sht = Nothing
Set CNN = Nothing
Set rs = Nothing
Set Rng = Nothing
End Sub

复制代码

3190496160 · 发表于 2024-6-28 08:54

Sub 分类汇总()
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "数据源为空！": End
ar = .Range("a1:c" & r)
ReDim br(1 To 100, 1 To 500)
br(1, 1) = "区域"
y = 1: k = 1
For i = 2 To UBound(ar)
      If ar(i, 1) <> "" Then
         t = d(ar(i, 2))
         If t = "" Then
            k = k + 1
            d(ar(i, 2)) = k
            t = k
            br(k, 1) = ar(i, 2)
         End If
         lh = d(ar(i, 1))
         If lh = "" Then
            y = y + 1
            d(ar(i, 1)) = y
            lh = y
            br(1, y) = ar(i, 1)
         End If
         br(t, lh) = br(t, lh) + ar(i, 3)
      End If
Next i
.[h1].CurrentRegion.Borders.LineStyle = 0
.[h1].CurrentRegion = Empty
.[h1].Resize(k, y) = br
.[h1].Resize(k, y).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-6-28 08:55

求助表.rar (23.85 KB, 下载次数: 7)

		自动登录	找回密码
密码			免费注册

[求助] 如何用VBA代码，实现一维表转换成二维表

评分

评分

评分