请教数据排列样式转换

Amway@2022

原始数据样式

上图为原始数据样式，我想把数据样式整理成下图的样式，其中原始数据中有忽略项的数据无需处理。目前我只需要整理四家公司的数据

需求样式

请老师帮忙指点，用vba如何编写代码，谢谢

ykcbf1100

一键生成

ykcbf1100

1. Sub ykcbf()   '//2025.3.26   排重汇总      全表自动生成
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     ReDim brr(1 To 10000, 1 To 100)
   
6.     m = 1: n = 1
   
7.     On Error Resume Next
   
8.     arr = Sheets("Sheet1").UsedRange
   
9.     brr(1, 1) = arr(1, 1)
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 1)
    
12.         If Not d.exists(s) Then
    
13.             m = m + 1
    
14.             d(s) = m
    
15.             brr(m, 1) = arr(i, 1)
    
16.         End If
    
17.         r = d(arr(i, 1))
    
18.         s = arr(i, 2)
    
19.         If Not d.exists(s) Then
    
20.             n = n + 1
    
21.             d(s) = n
    
22.             brr(1, n) = s
    
23.         End If
    
24.         c = d(arr(i, 2))
    
25.         brr(r, c) = brr(r, c) + arr(i, 3)
    
26.     Next
    
27.     With Sheets("Sheet2")
    
28.         .UsedRange.Clear
    
29.         .Cells.Interior.ColorIndex = 0
    
30.         .[a1].Resize(1, n).Interior.Color = 49407
    
31.         .[a2].Resize(m - 1, 1).Interior.Color = 5296274
    
32.         With .[a1].Resize(m, n)
    
33.             .Value = brr
    
34.             .Borders.LineStyle = 1
    
35.             .HorizontalAlignment = xlCenter
    
36.             .VerticalAlignment = xlCenter
    
37.             With .Font
    
38.                 .Name = "微软雅黑"
    
39.                 .Size = 11
    
40.             End With
    
41.         End With
    
42.         Set Rng = .[a2].Resize(m - 1, n)
    
43.         Rng.Sort Rng.Columns(1), 1, Orientation:=1
    
44.     End With
    
45.     Application.ScreenUpdating = True
    
46.     MsgBox "OK！"
    
47. End Sub
    
48. 
    

复制代码

dambcer

透视表就行了。。。。。。。。。。。

清风竹-

本代码由DeepSeek生成。

shiruiqiang

飞天篮球猪

仅供参考...

taller

实例.7z (24.38 KB, 下载次数: 0)

2025-3-26 11:08 上传

点击文件名下载附件

baofa2

1. Option Explicit
   
2. 
   
3. Sub test123() '
   
4.   Dim conn As Object, rs As Object
   
5.   Dim strConn As String, strSQL As String
   
6.   Dim ar, i As Integer
   
7.   Set conn = CreateObject("ADODB.Connection")
   
8.   Set rs = CreateObject("ADODB.Recordset")
   
9.   If Application.Version < 12 Then
   
10.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
    
11.   Else
    
12.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
    
13.   End If
    
14.   conn.Open strConn & ThisWorkbook.FullName
    
15.   With Worksheets("Sheet2")
    
16.     .Activate
    
17.     .UsedRange.Offset(1).ClearContents
    
18.     ar = Application.Rept(.Range("A1").CurrentRegion.Value, 1)
    
19.   End With
    
20.   For i = 2 To UBound(ar)
    
21.     If Len(ar(i)) Then strSQL = strSQL & ",'" & ar(i) & "'"
    
22.   Next
    
23.   If Len(strSQL) > 0 Then strSQL = " IN (" & Mid(strSQL, 2) & ")"
    
24.   strSQL = "TRANSFORM MAX(出厂价) SELECT 日期 FROM [Sheet1$] WHERE 忽略 IS NULL GROUP BY 日期 PIVOT 公司" & strSQL
    
25.   rs.Open strSQL, conn, 1, 3
    
26.   With Range("A1")
    
27.     For i = 0 To rs.Fields.Count - 1
    
28.       .Offset(0, i) = rs.Fields(i).Name
    
29.     Next
    
30.     .Offset(1).CopyFromRecordset rs
    
31.   End With
    
32.   rs.Close
    
33.   Set rs = Nothing
    
34.   conn.Close
    
35.   Set conn = Nothing
    
36. End Sub

复制代码

IE_Crayon

代码审核中...