二维表转换

ddz79101

老师！有张表，我想按企业名称和日期金额转换为二维表。请老师帮忙看看。表为简化，企业名称为3个，实际不确定，月份也只取1季度，实际为全年12个月。

limonet

一、最快速：数据透视表
二、transform

limonet

关键字：group by

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select 购货单位,Month(购货日期) as 月,货品总额 From [Sheet1$A:K] Where 购货单位<>''" _
    & "Union All Select ' 合计',Month(购货日期) as 月,Sum(货品总额) From [Sheet1$A:K] Where 购货单位<>'' Group By Month(购货日期)" _
    & "Union All Select 购货单位,'小计',Sum(货品总额) From [Sheet1$A:K] Where 购货单位<>'' Group By 购货单位"
    StrSQL = "TransForm Sum(货品总额) Select 购货单位 From (" & StrSQL & ")  Group By  购货单位 Order By 购货单位 Desc Pivot 月"
    Range("N2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

baofa2

1. Sub test11()  '
   
2.   
   
3.   Dim results(), data, dict As Object, strKey As String, i As Long, j As Long
   
4.   Dim rowSize As Long, colSize As Long, posRow As Long, posCol As Long
   
5.   
   
6.   Application.ScreenUpdating = False
   
7.   
   
8.   Set dict = CreateObject("Scripting.Dictionary")
   
9.   data = Sheet1.Range("A1").CurrentRegion.Value
   
10.   ReDim results(1 To UBound(data), 1 To 14)
    
11.   rowSize = 1
    
12.   colSize = 1
    
13.   results(rowSize, colSize) = data(1, 2)
    
14.   For i = 2 To UBound(data)
    
15.     strKey = Trim(data(i, 2))
    
16.     If Not dict.Exists(strKey) Then
    
17.       rowSize = rowSize + 1
    
18.       results(rowSize, 1) = strKey
    
19.       dict.Add strKey, rowSize
    
20.     End If
    
21.     posRow = dict(strKey)
    
22.     strKey = Format(CDate(data(i, 1)), "M月")  '开什么玩笑，2018-02-29 存在吗？在这个地方搞晕了。
    
23.     If strKey = "" Then strKey = "(空白)"
    
24.     If Not dict.Exists(strKey) Then
    
25.       colSize = colSize + 1
    
26.       results(1, colSize) = strKey
    
27.       dict.Add strKey, colSize
    
28.     End If
    
29.     posCol = dict(strKey)
    
30.     results(posRow, posCol) = results(posRow, posCol) + Val(data(i, 8))
    
31.   Next
    
32.   rowSize = rowSize + 1
    
33.   colSize = colSize + 1
    
34.   results(rowSize, 1) = "合计"
    
35.   results(1, colSize) = "合计"
    
36.   For j = 2 To colSize - 1
    
37.     For i = 2 To rowSize - 1
    
38.       results(rowSize, j) = results(rowSize, j) + results(i, j)
    
39.       results(i, colSize) = results(i, colSize) + results(i, j)
    
40.     Next
    
41.     results(i, colSize) = results(i, colSize) + results(i, j)
    
42.   Next
    
43.   With Sheet1.Range("N1")
    
44.     .CurrentRegion.Clear
    
45.     With .Resize(rowSize, colSize)
    
46.       .HorizontalAlignment = xlCenter
    
47.       .Borders.LineStyle = xlContinuous
    
48.       .Rows(1).Font.Bold = True
    
49.       .Value = results
    
50.     End With
    
51.   End With
    
52.   Set dict = Nothing
    
53.   
    
54.   Application.ScreenUpdating = True
    
55.   Beep
    
56. End Sub

复制代码

ykcbf1100

全表自动生成，行列均可自行扩展。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.8
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     r = Cells(Rows.Count, 2).End(3).Row
   
7.     arr = Range("a1").Resize(r, 8)
   
8.     ReDim brr(1 To UBound(arr), 1 To 100)
   
9.     brr(1, 1) = arr(1, 2)
   
10.     m = 1: n = 1
    
11.     On Error Resume Next
    
12.     For i = 2 To UBound(arr)
    
13.         s = Month(arr(i, 1))
    
14.         If Not d.exists(s) Then
    
15.             n = n + 1
    
16.             d(s) = n
    
17.             brr(1, n) = s & "月"
    
18.         End If
    
19.         s = arr(i, 2)
    
20.         If Not d.exists(s) Then
    
21.             m = m + 1
    
22.             d(s) = m
    
23.             brr(m, 1) = s
    
24.         End If
    
25.         r = d(arr(i, 2)): c = d(Month(arr(i, 1)))
    
26.         brr(r, c) = brr(r, c) + arr(i, 8)
    
27.     Next
    
28.     [n:z].Clear
    
29.     [n1].Resize(1, n + 1).Interior.Color = 49407
    
30.     With [n1].Resize(m + 1, n + 1)
    
31.         .Value = brr
    
32.         .Borders.LineStyle = 1
    
33.         .HorizontalAlignment = xlCenter
    
34.         .VerticalAlignment = xlCenter
    
35.         With .Font
    
36.             .Name = "微软雅黑"
    
37.             .Size = 11
    
38.         End With
    
39.     End With
    
40.     Cells(1, n + 14) = "合计"
    
41.     For i = 2 To m + 1
    
42.         Cells(i, n + 14) = Application.Sum(Range(Cells(i, "n"), Cells(i, n + 13)))
    
43.     Next
    
44.     m = m + 1
    
45.     Cells(m, "n") = "合计"
    
46.     Cells(m, "o").Resize(1, n).FormulaR1C1 = "=SUM(R2C:R" & "[-1]C)"
    
47.     Set d = Nothing
    
48.     MsgBox "OK！"
    
49. End Sub
    

复制代码

ddz79101

ykcbf1100 发表于 2024-5-8 12:37
参与一下。。。

谢谢老师！运行成功！只是我想将你代码其另存表时：
sheet2.[a:m].Clear
    sheet2.[a1].Resize(1, n + 1).Interior.Color = 49407
    With sheet2.[a1].Resize(m + 1, n + 1)
        .Value = brr
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        With .Font
            .Name = "微软雅黑"
            .Size = 11
        End With
    End With
    sheet2.Cells(1, n + 1) = "合计"
    For i = 2 To m + 1
        sheet2.Cells(i, n + 1) = Application.Sum(sheet2.Range(Cells(i, "a"), Cells(i, n)))
    Next
    m = m + 1
    sheet2.Cells(m, "a") = "合计"
    sheet2.Cells(m, "b").Resize(1, n).FormulaR1C1 = "=SUM(R2C:R" & "[-1]C)"
    Set d = Nothing
    MsgBox "OK！"
此句横向合计出不来，你可以帮我看看吗?

ddz79101

baofa2 发表于 2024-5-8 12:11

谢谢老师！运行成功！

ddz79101

limonet 发表于 2024-5-8 12:04
关键字：group by

谢谢老师！运行成功