有点难度的数据整合分析

ericxzhou

MySQL了解一下

jjmysjg

今铭昔 发表于 2022-5-16 20:50

Set rng = .Range("A3")
变量没定义

sdytsxd991122

sdytsxd991122

效果表里的行数比基础数据还多，没验证不知是否正确？

今铭昔

jjmysjg 发表于 2022-5-16 22:29
Set rng = .Range("A3")
变量没定义

本来是想以rng为起点使用currentRegion属性上边框的，后来觉得判断是否为空值就可以了，用不上就把声明给删了，却是忘了删这一行了

今铭昔

准提部林 发表于 2022-5-16 22:11
區域範圍, 只加外圍框線
可參考
range("A1:D9").BorderAround  Weight:=xlThin

Range对象原来还有这个方法，学到了。使用Mid来控制列来赋值，这个操作真是妙啊。一个循环内可以解决的事情，就不必再多开一个循环了，这点我的代码确实写得冗长了。我觉得Brr的行数不需要增加，因为有2019年必然有2021年的，假设它们在【基本数据】里各自只有一行，那么在【效果】里加上空出的一行，也是使用两行而已，而且这种极端情况也不多见，所以最终是用不完它的行数的。

blackttea1

学习高手的代码！

justdoit2003

学习了各位高手的VBA方案。但是能不能提供一个用函数公式的解决方案呢？那也一定很精彩。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr()
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("基础数据")
   
9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
10.     arr = .Range("a2:h" & r)
    
11.   End With
    
12.   For i = 1 To UBound(arr)
    
13.     nd = Year(arr(i, 1))
    
14.     If Not d.exists(arr(i, 4)) Then
    
15.       Set d(arr(i, 4)) = CreateObject("scripting.dictionary")
    
16.     End If
    
17.     If Not d(arr(i, 4)).exists(nd) Then
    
18.       m = 1
    
19.       ReDim brr(1 To 4, 1 To m)
    
20.     Else
    
21.       brr = d(arr(i, 4))(nd)
    
22.       m = UBound(brr, 2) + 1
    
23.       ReDim Preserve brr(1 To 4, 1 To m)
    
24.     End If
    
25.     brr(1, m) = arr(i, 7)
    
26.     brr(2, m) = arr(i, 3)
    
27.     brr(3, m) = arr(i, 1)
    
28.     brr(4, m) = arr(i, 8)
    
29.     d(arr(i, 4))(nd) = brr
    
30.   Next
    
31.   ReDim crr(1 To 10000, 1 To 11)
    
32.   m = 1
    
33.   x = 0
    
34.   For Each aa In d.keys
    
35.     hs = 0
    
36.     For Each bb In d(aa).keys
    
37.       n = IIf(bb = 2019, 1, 7)
    
38.       brr = d(aa)(bb)
    
39.       crr(m, 1) = aa
    
40.       crr(m, 7) = aa
    
41.       If hs < UBound(brr, 2) Then
    
42.         hs = UBound(brr, 2)
    
43.       End If
    
44.       For j = 1 To UBound(brr, 2)
    
45.         For i = 1 To UBound(brr)
    
46.           crr(m + j - 1, n + i) = brr(i, j)
    
47.         Next
    
48.       Next
    
49.     Next
    
50.     x = x + 1
    
51.     ReDim Preserve zrr(1 To x)
    
52.     zrr(x) = Array(m, hs)
    
53.     m = m + hs + 1
    
54.   Next
    
55.   With Worksheets("效果")
    
56.     .UsedRange.Offset(2, 0).Clear
    
57.     .Range("a3").Resize(m, UBound(crr, 2)) = crr
    
58.     For k = 1 To UBound(zrr)
    
59.       With .Cells(zrr(k)(0) + 2, 1).Resize(zrr(k)(1), 11)
    
60.         .BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
    
61.       End With
    
62.     Next
    
63.     With .Range("f1:f" & 2 + m - 2)
    
64.       .Interior.ColorIndex = 6
    
65.     End With
    
66.   End With
    
67. End Sub
    

复制代码

chxw68

凑凑热闹。