Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

数据透视表40+个常用小技巧,让你一次学会!
查看: 148|回复: 16

EXCEL VBA 类似转置功能如何写,求助!

[复制链接]
发表于 2022-6-20 08:00 | 显示全部楼层 |阅读模式
数据:
日期编号
名字
级别
2021年12月12345杨1D
2022年1月12345杨1B
2022年2月12345杨1B
2022年3月12345杨1B
2022年4月12345杨1A
2022年5月12345杨1B


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


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

test.zip

13.1 KB, 下载次数: 13

发表于 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

New Microsoft Excel Worksheet.rar

21.29 KB, 下载次数: 4

回复

使用道具 举报

发表于 2022-6-20 12:53 | 显示全部楼层
  1. Option Explicit

  2. Sub demo()
  3. Dim arr, brr, crr, drr, a As Integer, b As Integer
  4. arr = Sheet1.Range("b2:b" & Sheet1.Cells(Sheet1.Rows.Count, "b").End(xlUp).Row) '编号
  5. brr = Sheet1.Range("c2:c" & Sheet1.Cells(Sheet1.Rows.Count, "b").End(xlUp).Row) '名字
  6. crr = Sheet1.Range("d2:d" & Sheet1.Cells(Sheet1.Rows.Count, "b").End(xlUp).Row) '评级
  7. drr = Sheet1.Range("a2:a" & Sheet1.Cells(Sheet1.Rows.Count, "b").End(xlUp).Row) '日期
  8. 'Dim d1 As New Dictionary, d2 As New Dictionary
  9. Dim d1, d2
  10. Set d1 = CreateObject("scripting.dictionary")
  11. Set d2 = CreateObject("scripting.dictionary")
  12. Dim i As Long, j As Long
  13.     For i = 1 To UBound(brr)
  14.       d1(drr(i, 1)) = ""
  15.       d2(arr(i, 1)) = ""
  16.     Next i
  17.     With Sheet3.Range("a1")
  18.         .Value = "编号"
  19.         .Offset(0, 1) = "名字"
  20.         .Offset(1, 0).Resize(d2.Count) = Application.Transpose(d2.Keys)
  21.         .Offset(0, 2).Resize(, d1.Count) = d1.Keys
  22.     End With
  23.     Sheet3.Range("1:1").NumberFormat = "M月"
  24.     With Sheet3
  25.         .Range("b2").Formula = "=VLOOKUP(A2,Sheet数据!B:C,2,0)"
  26.         .Range("b2:b" & d2.Count + 1).FillDown
  27.         .Range("c2").FormulaArray = "=INDEX(Sheet数据!$D:$D,MATCH(1,(Sheet数据!$A:$A=C$1)*(Sheet数据!$B:$B=$A2),0))"
  28.         .Range("c2").Copy
  29.         .Range("c2").Resize(d2.Count, d1.Count).PasteSpecial (xlPasteFormulas)
  30.     End With
  31.     MsgBox "已完成"
  32. End Sub
复制代码


demo.zip

24 KB, 下载次数: 4

回复

使用道具 举报

发表于 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
回复

使用道具 举报

 楼主| 发表于 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       


回复

使用道具 举报

 楼主| 发表于 2022-6-20 15:05 | 显示全部楼层

.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)
最后一条数值粘贴格式选择报 ...

附件里面的报错么,发来看下,我运行没问题
1655711966328.jpg
回复

使用道具 举报

发表于 2022-6-20 16:24 | 显示全部楼层
gemeng25569 发表于 2022-6-20 14:55
首先谢谢你hasyh2008,有几个地方帮再看看,我需求的不光是单纯的汇总
1. sheet结果,
    1, 原表的 ...

用后发的代码
回复

使用道具 举报

发表于 2022-6-20 16:30 | 显示全部楼层
本帖最后由 hasyh2008 于 2022-6-20 17:00 编辑
gemeng25569 发表于 2022-6-20 14:55
首先谢谢你hasyh2008,有几个地方帮再看看,我需求的不光是单纯的汇总
1. sheet结果,
    1, 原表的 ...

人员,月份不受限。

棋盘法(20220620).rar

22.71 KB, 下载次数: 6

回复

使用道具 举报

 楼主| 发表于 2022-6-21 13:42 | 显示全部楼层
林木水 发表于 2022-6-20 16:00
附件里面的报错么,发来看下,我运行没问题

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

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

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2022-6-30 08:28 , Processed in 0.480473 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表