sheet2 a1 指定年份

cmo9020

请教导师们一个简单问题，
现在是2023年，
要在sheet2 a1 指定年份
在带入数据，请问要如何修改，谢谢导师们，恳请帮忙
kkery.zip (202.98 KB, 下载次数: 20)

2023-1-10 12:35 上传

点击文件名下载附件

于箱长

我是没看懂，路过帮顶了

陆离Lowry

我也愣是没看懂。

ykcbf1100

看别人的代码不习惯，还不如自己写一个。

ykcbf1100

代码如下：

1. Sub ykcbf()  '//2023.1.10
   
2.     Application.ScreenUpdating = False
   
3.     Dim arr, brr, d, r
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     Dim tm: tm = Timer
   
7.     nf = Sheet2.[a1]
   
8.     On Error Resume Next
   
9.     With Sheet1
   
10.         r = .Cells(Rows.Count, 1).End(xlUp).Row
    
11.         arr = .Range("a1:n" & r)
    
12.     End With
    
13.     For i = 2 To UBound(arr)
    
14.         yf = Month(arr(i, 3)) & "月份"
    
15.         s = arr(i, 12) & "|" & yf
    
16.         If Year(arr(i, 3)) = nf Then
    
17.             If arr(i, 1) <> Empty Then
    
18.                 d1(yf) = d1(yf) + 1
    
19.                 If arr(i, 12) <> Empty Then
    
20.                     d(s) = d(s) + 1
    
21.                 End If
    
22.             End If
    
23.         End If
    
24.     Next
    
25.     t = d.items
    
26.     ReDim brr(1 To UBound(arr), 1 To 13)
    
27.     For Each k In d.keys
    
28.         m = m + 1
    
29.         brr(m, 1) = Split(k, "|")(0)
    
30.     Next
    
31.     With Sheet2
    
32.         .UsedRange.Offset(3).Clear
    
33.         .[a4].Resize(m, 1) = brr
    
34.         arr = .Range("a3").Resize(1000, 13)
    
35.         For i = 2 To UBound(arr)
    
36.             For j = 2 To UBound(arr, 2)
    
37.                 s = arr(i, 1) & "|" & arr(1, j)
    
38.                 If d.exists(s) Then
    
39.                     arr(i, j) = d(s)
    
40.                 End If
    
41.             Next
    
42.         Next
    
43.         .Range("a3").Resize(1000, 13) = arr
    
44.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
45.         .Cells(r + 1, 1) = "统计"
    
46.         .Cells(r + 1, 2).Resize(1, 12).FormulaR1C1 = "=SUM(R4C:R" & "[-1]C)"    '//全部合计
    
47.         .Cells(r + 2, 1) = "月份总笔数"
    
48.         For j = 2 To 13
    
49.             .Cells(r + 2, j) = d1(arr(1, j))
    
50.         Next
    
51.         .Cells(r + 3, 1) = "不良率"
    
52.         For j = 2 To 13
    
53.             .Cells(r + 3, j) = Format(.Cells(r + 1, j) / .Cells(r + 2, j), "0.00%")
    
54.         Next
    
55.         .[a4].Resize(r, 13).Borders.LineStyle = 1
    
56.     End With
    
57.     Set d = Nothing
    
58.     Set d1 = Nothing
    
59.     Application.ScreenUpdating = True
    
60.     MsgBox "运行完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
61. End Sub
    

复制代码

ykcbf1100

看了楼主以往的帖子，感觉关注人少是有原因的。

cmo9020

ykcbf1100 发表于 2023-1-10 16:24
看了楼主以往的帖子，感觉关注人少是有原因的。

谢谢导师的帮忙~我知道问题太多
但又很爱问,谢谢您~天气凉了多穿暖些

ykcbf1100

cmo9020 发表于 2023-1-10 17:48
谢谢导师的帮忙~我知道问题太多
但又很爱问,谢谢您~天气凉了多穿暖些

你也是老会员了，有些道理应该懂的。
对于自己的求助帖子，要多回帖；
对于帮助你的人，要说谢谢，并送上免费的小花。
这样，以后帮助你的人才会越来越多。