[已解决]EXCEL VBA 类似转置功能如何写，求助！

gemeng25569 · 发表于 2022-6-20 08:00

数据：

日期	编号	名字	级别
2021年12月	12345	杨1	D
2022年1月	12345	杨1	B
2022年2月	12345	杨1	B
2022年3月	12345	杨1	B
2022年4月	12345	杨1	A
2022年5月	12345	杨1	B

VBA结果：

		展示
编号	名字	12月	1月	2月	3月	4月	5月
12345	杨1	D	B	B	B	A	B

数据大概有几万条，期望大师们给个VBA代码，谢谢

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-6-21 19:04

再试试

跳转到最佳答案楼层

hasyh2008 · 发表于 2022-6-20 09:04

本帖最后由 hasyh2008 于 2022-6-20 09:08 编辑

Sub 汇总()
On Error Resume Next
Dim D1, D2
Dim R%, K%, I%, Arr, Brr(), Str$
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
Arr = Sheet1.Range("A1").CurrentRegion
K = 2
For R = 2 To UBound(Arr)
      If Not D1.exists(Arr(R, 1)) Then
         K = K + 1
         D1(Arr(R, 1)) = K
      End If
Next R
ReDim Brr(1 To 1000, 1 To K)
For R = 2 To UBound(Arr)
      Str = Arr(R, 2) & Arr(R, 3)
      If D2.exists(Str) Then
         Brr(D2(Str), D1(Arr(R, 1))) = Arr(R, 4)
      Else
         I = I + 1
         D2(Str) = I
         Brr(I, 1) = Arr(R, 2)
         Brr(I, 2) = Arr(R, 3)
         Brr(I, D1(Arr(R, 1))) = Arr(R, 4)
      End If
Next R
Sheet2.Range("A3").Resize(I, K) = Brr
End Sub

林木水 · 发表于 2022-6-20 12:53

Option Explicit
Sub demo()
Dim arr, brr, crr, drr, a As Integer, b As Integer
arr = Sheet1.Range("b2:b" & Sheet1.Cells(Sheet1.Rows.Count, "b").End(xlUp).Row) '编号
brr = Sheet1.Range("c2:c" & Sheet1.Cells(Sheet1.Rows.Count, "b").End(xlUp).Row) '名字
crr = Sheet1.Range("d2:d" & Sheet1.Cells(Sheet1.Rows.Count, "b").End(xlUp).Row) '评级
drr = Sheet1.Range("a2:a" & Sheet1.Cells(Sheet1.Rows.Count, "b").End(xlUp).Row) '日期
'Dim d1 As New Dictionary, d2 As New Dictionary
Dim d1, d2
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Dim i As Long, j As Long
For i = 1 To UBound(brr)
d1(drr(i, 1)) = ""
d2(arr(i, 1)) = ""
Next i
With Sheet3.Range("a1")
.Value = "编号"
.Offset(0, 1) = "名字"
.Offset(1, 0).Resize(d2.Count) = Application.Transpose(d2.Keys)
.Offset(0, 2).Resize(, d1.Count) = d1.Keys
End With
Sheet3.Range("1:1").NumberFormat = "M月"
With Sheet3
.Range("b2").Formula = "=VLOOKUP(A2,Sheet数据!B:C,2,0)"
.Range("b2:b" & d2.Count + 1).FillDown
.Range("c2").FormulaArray = "=INDEX(Sheet数据!$D:$D,MATCH(1,(Sheet数据!$A:$A=C$1)*(Sheet数据!$B:$B=$A2),0))"
.Range("c2").Copy
.Range("c2").Resize(d2.Count, d1.Count).PasteSpecial (xlPasteFormulas)
End With
MsgBox "已完成"
End Sub

复制代码

hasyh2008 · 发表于 2022-6-20 13:39

本帖最后由 hasyh2008 于 2022-6-20 13:46 编辑

Sub 汇总()
On Error Resume Next
Dim D1, D2
Dim R%, K%, I%, Arr, Brr(), Str$
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
Arr = Sheet1.Range("A1").CurrentRegion
K = 2
For R = 2 To UBound(Arr)
      If Not D1.exists(Arr(R, 1)) Then
         K = K + 1
         D1(Arr(R, 1)) = K
      End If
Next R
Sheet2.Range("C2").Resize(1, UBound(D1.keys) + 1) = D1.keys
ReDim Brr(1 To 1000, 1 To K)
For R = 2 To UBound(Arr)
      Str = Arr(R, 2) & Arr(R, 3)
      If D2.exists(Str) Then
         Brr(D2(Str), D1(Arr(R, 1))) = Arr(R, 4)
      Else
         I = I + 1
         D2(Str) = I
         Brr(I, 1) = Arr(R, 2)
         Brr(I, 2) = Arr(R, 3)
         Brr(I, D1(Arr(R, 1))) = Arr(R, 4)
      End If
Next R
Sheet2.Range("A3").Resize(I, K) = Brr
End Sub

gemeng25569 · 发表于 2022-6-20 14:55

hasyh2008 发表于 2022-6-20 09:04
Sub 汇总()
On Error Resume Next
Dim D1, D2

首先谢谢你hasyh2008，有几个地方帮再看看，我需求的不光是单纯的汇总
1. sheet结果，
1，原表的，编号姓名后面还有很多列内容，都是用VB生成的数据
2，“ sheet结果” 月份是会有变化的，“sheet数据" 的月份也会增加其它月份

我需求的类似VLOOKUP那样，根据编号去得出当月的ABCD，当然VLOOKUP不能满足，因为还有月份条件，需要更复杂的公式才能满足，月份开始前面有几十列内容都是用VB生成的数据，所以需要这月份下面对应的ABCD也能用VB生成，感谢感谢！

编号名字 12月 1月 2月 3月 4月 5月
12345 杨1 D B B B A B
23456 刘2 A C C B B B
33445 开3 B B C C C C
344322 张5 B A B B C B
342342 郭二 A B B B B D
179263 许三 C C B B D B
446667 张四 D B B B B D
223446 魏五 B B B A B

gemeng25569 · 发表于 2022-6-20 15:05

林木水发表于 2022-6-20 12:53

.Range("c2").Resize(d2.Count, d1.Count).PasteSpecial (xlPasteFormulas)
最后一条数值粘贴格式选择报错哦，
感谢再帮看看

林木水 · 发表于 2022-6-20 16:00

gemeng25569 发表于 2022-6-20 15:05
.Range("c2").Resize(d2.Count, d1.Count).PasteSpecial (xlPasteFormulas)
最后一条数值粘贴格式选择报 ...

附件里面的报错么，发来看下，我运行没问题

hasyh2008 · 发表于 2022-6-20 16:24

gemeng25569 发表于 2022-6-20 14:55
首先谢谢你hasyh2008，有几个地方帮再看看，我需求的不光是单纯的汇总
1. sheet结果，
1，原表的 ...

用后发的代码

hasyh2008 · 发表于 2022-6-20 16:30

本帖最后由 hasyh2008 于 2022-6-20 17:00 编辑

gemeng25569 发表于 2022-6-20 14:55
首先谢谢你hasyh2008，有几个地方帮再看看，我需求的不光是单纯的汇总
1. sheet结果，
1，原表的 ...

人员，月份不受限。

gemeng25569 · 发表于 2022-6-21 13:42

林木水发表于 2022-6-20 16:00
附件里面的报错么，发来看下，我运行没问题

谢谢你，报错截图在附件中，再帮看看

用公式是我想要的结果，根据日期编号名字算出对应的ABCD，就是上万条数据的时候可能会很卡吧

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