转置

雪豸狼

求助，将图1转换成图2

lovelfg

这不就是简单的数据透视吗？

雪豸狼

lovelfg 发表于 2019-10-11 18:11
这不就是简单的数据透视吗？

菜鸟一个  求教

xuemei0216

请上传附件

lovelfg

雪豸狼 发表于 2019-10-11 18:19
菜鸟一个  求教

我录屏后附件大小太大，上传不了，你可以百度一下，很简单的

xiangbaoan

Option Explicit
Sub test()
Dim Cn As Object, Rs As Object, Sq$, i%, Sh As Worksheet
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Set Sh = Sheets("数据表") '这里的工作表名，根据实际填写
Sq = "TRANSFORM SUM(金额) SELECT 姓名 FROM [" & Sh.Name & "$A1:C" & Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row & "] GROUP BY 姓名 PIVOT 工资项"
Set Rs = Cn.Execute(Sq)
With Sh.Range("e1") '输出位置自行调整
    .Resize(Rows.Count, 4).ClearContents
    For i = 0 To Rs.Fields.Count - 1
        .Offset(0, i) = Rs.Fields(i).Name
    Next
    .Offset(1).CopyFromRecordset Rs
End With
Cn.Close
Set Rs = Nothing
Set Cn = Nothing
Set Sh = Nothing
End Sub

yaozong

1. Sub test()
   
2. Dim d, arr, i&, j&, m&, n&, s, g, w
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr = [a1].CurrentRegion.Value
   
5. ReDim brr(1 To UBound(arr), 1 To 10)
   
6. m = 1: n = 1: brr(m, n) = "姓名"
   
7. For i = 2 To UBound(arr)
   
8.   s = arr(i, 1): g = arr(i, 2): w = s & g
   
9.   If Not d.exists(s) Then
   
10.     m = m + 1
    
11.     d(s) = m
    
12.     brr(m, 1) = s
    
13.   End If
    
14.   If Not d.exists(g) Then
    
15.     n = n + 1
    
16.     d(g) = n
    
17.     brr(1, n) = g
    
18.   End If
    
19.   d(w) = d(w) + arr(i, 3)
    
20. Next
    
21. For i = 2 To m
    
22.   For j = 2 To n
    
23.     w = brr(i, 1) & brr(1, j)
    
24.     brr(i, j) = d(w)
    
25.   Next
    
26. Next
    
27. [f1].CurrentRegion.Clear
    
28. [f1].Resize(m, n) = brr
    
29. End Sub

复制代码

yaozong

参考附件。。。。。。。。。。。

yaozong

也可精简为：

Sub yyz()
Dim d, arr, i&, m&, n&, s, g
Set d = CreateObject("Scripting.Dictionary")
arr = [a1].CurrentRegion.Value
ReDim brr(1 To UBound(arr), 1 To 10)
m = 1: n = 1: brr(m, n) = "姓名"
For i = 2 To UBound(arr)
  s = arr(i, 1) & "1": g = arr(i, 2) & "2"
  If Not d.exists(s) Then
    m = m + 1: d(s) = m: brr(m, 1) = arr(i, 1)
  End If
  If Not d.exists(g) Then
    n = n + 1: d(g) = n: brr(1, n) = arr(i, 2)
  End If
  brr(d(s), d(g)) = brr(d(s), d(g)) + arr(i, 3)
Next
[f1].CurrentRegion.Clear
[f1].Resize(m, n) = brr
End Sub

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, m
  arr = [a1].CurrentRegion.Offset(1).Resize(, 4)
  For i = 1 To UBound(arr, 1) - 1 Step 3
    m = m + 1
    arr(m, 1) = arr(i, 1): arr(m, 2) = arr(i, 3)
    arr(m, 3) = arr(i + 1, 3): arr(m, 4) = arr(i + 2, 3)
  Next
  [e2].Resize(m, UBound(arr, 2)) = arr
End Sub