如何实现日期归类转置

sulgz

使用VBA实现转置功能：
1、“应收明细甲”的A列是年、B列是月数、C列是甲方、d列是乙方、e列是金额。
2、甲方存放到“测试表”的第4行开始的B列、乙方存放到“测试表”的第4行开始的B列，年存放到“测试表”j列开始的第二行、月存放到“测试表”j列开始的第三行、金额存放到甲方姓名、乙方姓名与年月对应行列的单元格”
求助.zip (12.06 KB, 下载次数: 2)

2024-1-30 23:42 上传

点击文件名下载附件

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.1.31
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("应收明细甲")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 5)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 4) & "|" & arr(i, 3) & "|" & arr(i, 1) & "|" & arr(i, 2)
    
11.         d(s) = arr(i, 5)
    
12.     Next
    
13.     With Sheets("测试表")
    
14.         r = .Cells(.Rows.Count, "b").End(xlUp).Row
    
15.         c = .UsedRange.Columns.Count
    
16.         arr = .[a1].Resize(r, c)
    
17.         For i = 4 To UBound(arr)
    
18.             For j = 10 To UBound(arr, 2)
    
19.                 s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(2, j) & "|" & arr(3, j)
    
20.                 If d.Exists(s) Then
    
21.                     arr(i, j) = d(s)
    
22.                 Else
    
23.                     arr(i, j) = ""
    
24.                 End If
    
25.             Next
    
26.         Next
    
27.         .[a1].Resize(r, c) = arr
    
28.     End With
    
29.     Set d = Nothing
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "OK！"
    
32. End Sub
    
33. 
    

复制代码

ykcbf1100

附件供参考。。。

sulgz

ykcbf1100 发表于 2024-1-31 07:45
附件供参考。。。

好厉害，谢谢