[已解决]周汇总代码修改

楚雪飞扬

请各位帮忙修改下周汇总代码，现在使用的代码是每7天汇总成一周，数据是求的平均值现在的需求需要将平均值采用求合（累加）的形式进行汇总并算出达成率！
Sub demo()
Application.ScreenUpdating = False
   md = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
   Rows.EntireRow.Hidden = False
   a = [a1].CurrentRegion
   For i = UBound(a) To 2 Step -1
      If InStr(1, a(i, 1), "M", 1) <> 0 Then 'If Mid(a(i, 1), 2, 1) = "M" Then
         Range(i & ":" & i).Delete
      End If
   Next
   a = [a1].CurrentRegion
   col = UBound(a, 2)
   ReDim s(1 To col)
   ReDim av(1 To col)
   For i = 2 To UBound(a)
      d = Day(a(i, 1)): m = Month(a(i, 1))
      If d = 1 Then w = 0
      For j = 2 To col
         If d Mod 7 = 1 Then s(j) = 0
         s(j) = s(j) + a(i, j)
      Next
      If d Mod 7 = 0 Then
         r = r + 1: w = w + 1
         Cells(i + r, 1).EntireRow.Insert
         Cells(i + r, 1) = m & "M" & w & "W"
         For j = 2 To col
            If d = 7 Then av(j) = 0
            Cells(i + r, j) = s(j) / 7: av(j) = av(j) + s(j) / 7
         Next
         Range(Cells(i + r - 7, 1), Cells(i + r - IIf(i + md(m) - d <= UBound(a), 0, 1), 1)).EntireRow.Hidden = True
      End If

      If d = md(m) Then
         r = r + 1
         Cells(i + r, 1).EntireRow.Insert
         Cells(i + r, 1) = m & "M"
         For j = 2 To col
            Cells(i + r, j) = (av(j) + IIf(d <> 28, s(j), 0)) / (w + d Mod 7)
         Next
         Range(Cells(i + r - (d - 1) Mod 7 - 1, 1), Cells(i + r - 1, 1)).EntireRow.Hidden = True
      End If
   Next
   Application.ScreenUpdating = True
End Sub

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2021-11-25 19:23

1. Sub demo()
   
2. Application.ScreenUpdating = False
   
3.    md = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
   
4.    Rows.EntireRow.Hidden = False
   
5.    a = [a1].CurrentRegion
   
6.    For i = UBound(a) To 2 Step -1
   
7.       If InStr(1, a(i, 1), "M", 1) <> 0 Then 'If Mid(a(i, 1), 2, 1) = "M" Then
   
8.          Range(i & ":" & i).Delete
   
9.       End If
   
10.    Next
    
11.    n = 1
    
12.    a = [a1].CurrentRegion
    
13.    col = UBound(a, 2)
    
14.    ReDim s(1 To col)
    
15.    ReDim av(1 To col)
    
16.    For i = 2 To UBound(a)
    
17.       d = Day(a(i, 1)): m = Month(a(i, 1))
    
18.       If d = 1 Then w = 0
    
19.       For j = 2 To col
    
20.          If d Mod 7 = 1 Then s(j) = 0
    
21.          s(j) = s(j) + a(i, j)
    
22.       Next
    
23.       If d Mod 7 = 0 Then
    
24.          r = r + 1: w = w + 1
    
25.          Cells(i + r, 1).EntireRow.Insert
    
26.          Cells(i + r, 1) = m & "M" & w & "W"
    
27.          For j = 2 To col - 1
    
28.             If j = col Then n = 7
    
29.             If d = 7 Then av(j) = 0
    
30.             Cells(i + r, j) = s(j) / n
    
31.          Next
    
32.          Cells(i + r, j) = Cells(i + r, j - 1) / Cells(i + r, j - 2)
    
33.          Range(Cells(i + r - 7, 1), Cells(i + r - IIf(i + md(m) - d <= UBound(a), 0, 1), 1)).EntireRow.Hidden = True
    
34.       End If
    
35. 
    
36.       If d = md(m) Then
    
37.          r = r + 1
    
38.          Cells(i + r, 1).EntireRow.Insert
    
39.          Cells(i + r, 1) = m & "M"
    
40.          For j = 2 To col
    
41.             Cells(i + r, j) = (av(j) + IIf(d <> 28, s(j), 0)) / (w + d Mod 7)
    
42.          Next
    
43.          Range(Cells(i + r - (d - 1) Mod 7 - 1, 1), Cells(i + r - 1, 1)).EntireRow.Hidden = True
    
44.       End If
    
45.    Next
    
46.    Application.ScreenUpdating = True
    
47. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Sub demo()
   
2. Application.ScreenUpdating = False
   
3.    md = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
   
4.    Rows.EntireRow.Hidden = False
   
5.    a = [a1].CurrentRegion
   
6.    For i = UBound(a) To 2 Step -1
   
7.       If InStr(1, a(i, 1), "M", 1) <> 0 Then 'If Mid(a(i, 1), 2, 1) = "M" Then
   
8.          Range(i & ":" & i).Delete
   
9.       End If
   
10.    Next
    
11.    n = 1
    
12.    a = [a1].CurrentRegion
    
13.    col = UBound(a, 2)
    
14.    ReDim s(1 To col)
    
15.    ReDim av(1 To col)
    
16.    For i = 2 To UBound(a)
    
17.       d = Day(a(i, 1)): m = Month(a(i, 1))
    
18.       If d = 1 Then w = 0
    
19.       For j = 2 To col
    
20.          If d Mod 7 = 1 Then s(j) = 0
    
21.          s(j) = s(j) + a(i, j)
    
22.       Next
    
23.       If d Mod 7 = 0 Then
    
24.          r = r + 1: w = w + 1
    
25.          Cells(i + r, 1).EntireRow.Insert
    
26.          Cells(i + r, 1) = m & "M" & w & "W"
    
27.          For j = 2 To col - 1
    
28.             If j = col Then n = 7
    
29.             If d = 7 Then av(j) = 0
    
30.             Cells(i + r, j) = s(j) / n
    
31.          Next
    
32.          Cells(i + r, j) = Cells(i + r, j - 1) / Cells(i + r, j - 2)
    
33.          Range(Cells(i + r - 7, 1), Cells(i + r - IIf(i + md(m) - d <= UBound(a), 0, 1), 1)).EntireRow.Hidden = True
    
34.       End If
    
35. 
    
36.       If d = md(m) Then
    
37.          r = r + 1
    
38.          Cells(i + r, 1).EntireRow.Insert
    
39.          Cells(i + r, 1) = m & "M"
    
40.          For j = 2 To col
    
41.             Cells(i + r, j) = (av(j) + IIf(d <> 28, s(j), 0)) / (w + d Mod 7)
    
42.          Next
    
43.          Range(Cells(i + r - (d - 1) Mod 7 - 1, 1), Cells(i + r - 1, 1)).EntireRow.Hidden = True
    
44.       End If
    
45.    Next
    
46.    Application.ScreenUpdating = True
    
47. End Sub

复制代码

楚雪飞扬

大灰狼1976 发表于 2021-11-25 19:23

现在有另一个问题，就是汇总后目标能不能不保持不变，或是直接填充上一单元格的内容！

大灰狼1976

不太明白你的意思，能举例说明吗？

楚雪飞扬

大灰狼1976 发表于 2021-11-25 20:51
不太明白你的意思，能举例说明吗？

就是我按你给我提供的代码，放到另一份文件运行时，目标那列数据发生了改变，应该是变成了百分比，代码要怎么改，目标列数值保持不变 ，的有文件目标列不固，有没有办法说，可以指定某一列（目标）的数据保持不变

大灰狼1976

可以的，你先发个新的附件上来，我要下班后或者明天才能下载确认。

楚雪飞扬

大灰狼1976 发表于 2021-11-26 10:41
可以的，你先发个新的附件上来，我要下班后或者明天才能下载确认。

附件已上传，有两个需要使用到的案例，麻烦老师抽空帮忙弄好，谢谢！

大灰狼1976

你附件里的案例1和案例2，和最初的要求完全不一样，需要重新说明一下：
1、案例1里面，目标列如何处理？其他列如何处理？
2、案例2里面，比例列和目标列如何处理？其他列如何处理？

楚雪飞扬

大灰狼1976 发表于 2021-11-27 15:02
你附件里的案例1和案例2，和最初的要求完全不一样，需要重新说明一下：
1、案例1里面，目标列如何处理？其 ...

案例1：B列至AF列采用累计汇总，AG(目标)数据不变，还是原来的数值
案例2：B列至C列采用累计汇总， D列（占比）C列除以B列得出结果，E(目标)数据不变，还是原来的数值

大灰狼1976

1. Sub 案例1()
   
2. Application.ScreenUpdating = False
   
3.    md = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
   
4.    Rows.EntireRow.Hidden = False
   
5.    a = [a1].CurrentRegion
   
6.    For i = UBound(a) To 2 Step -1
   
7.       If InStr(1, a(i, 1), "M", 1) <> 0 Then 'If Mid(a(i, 1), 2, 1) = "M" Then
   
8.          Range(i & ":" & i).Delete
   
9.       End If
   
10.    Next
    
11.    n = 1
    
12.    a = [a1].CurrentRegion
    
13.    col = UBound(a, 2)
    
14.    ReDim s(1 To col)
    
15.    ReDim av(1 To col)
    
16.    For i = 2 To UBound(a)
    
17.       d = Day(a(i, 1)): m = Month(a(i, 1))
    
18.       If d = 1 Then w = 0
    
19.       For j = 2 To col - 1
    
20.          If d Mod 7 = 1 Then s(j) = 0
    
21.          s(j) = s(j) + a(i, j)
    
22.       Next
    
23.       s(col) = a(i, col)
    
24.       If d Mod 7 = 0 Then
    
25.          r = r + 1: w = w + 1
    
26.          Cells(i + r, 1).EntireRow.Insert
    
27.          Cells(i + r, 1) = m & "M" & w & "W"
    
28.          For j = 2 To col
    
29.             If j = col Then n = 7
    
30.             If d = 7 Then av(j) = 0
    
31.             Cells(i + r, j) = s(j)
    
32.          Next
    
33.          Range(Cells(i + r - 7, 1), Cells(i + r - IIf(i + md(m) - d <= UBound(a), 0, 1), 1)).EntireRow.Hidden = True
    
34.       End If
    
35. 
    
36.       If d = md(m) Then
    
37.          r = r + 1
    
38.          Cells(i + r, 1).EntireRow.Insert
    
39.          Cells(i + r, 1) = m & "M"
    
40.          For j = 2 To col
    
41.             Cells(i + r, j) = (av(j) + IIf(d <> 28, s(j), 0)) / (w + d Mod 7)
    
42.          Next
    
43.          Range(Cells(i + r - (d - 1) Mod 7 - 1, 1), Cells(i + r - 1, 1)).EntireRow.Hidden = True
    
44.       End If
    
45.    Next
    
46.    Application.ScreenUpdating = True
    
47. End Sub

复制代码

1. Sub 案例2()
   
2. Application.ScreenUpdating = False
   
3.    md = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
   
4.    Rows.EntireRow.Hidden = False
   
5.    a = [a1].CurrentRegion
   
6.    For i = UBound(a) To 2 Step -1
   
7.       If InStr(1, a(i, 1), "M", 1) <> 0 Then 'If Mid(a(i, 1), 2, 1) = "M" Then
   
8.          Range(i & ":" & i).Delete
   
9.       End If
   
10.    Next
    
11.    n = 1
    
12.    a = [a1].CurrentRegion
    
13.    col = UBound(a, 2)
    
14.    ReDim s(1 To col)
    
15.    ReDim av(1 To col)
    
16.    For i = 2 To UBound(a)
    
17.       d = Day(a(i, 1)): m = Month(a(i, 1))
    
18.       If d = 1 Then w = 0
    
19.       For j = 2 To col - 2
    
20.          If d Mod 7 = 1 Then s(j) = 0
    
21.          s(j) = s(j) + a(i, j)
    
22.       Next
    
23.       s(col) = a(i, col)
    
24.       s(4) = s(3) / s(2)
    
25.       If d Mod 7 = 0 Then
    
26.          r = r + 1: w = w + 1
    
27.          Cells(i + r, 1).EntireRow.Insert
    
28.          Cells(i + r, 1) = m & "M" & w & "W"
    
29.          For j = 2 To col
    
30.             Cells(i + r, j) = s(j)
    
31.          Next
    
32.          Range(Cells(i + r - 7, 1), Cells(i + r - IIf(i + md(m) - d <= UBound(a), 0, 1), 1)).EntireRow.Hidden = True
    
33.       End If
    
34. 
    
35.       If d = md(m) Then
    
36.          r = r + 1
    
37.          Cells(i + r, 1).EntireRow.Insert
    
38.          Cells(i + r, 1) = m & "M"
    
39.          For j = 2 To col
    
40.             Cells(i + r, j) = (av(j) + IIf(d <> 28, s(j), 0)) / (w + d Mod 7)
    
41.          Next
    
42.          Range(Cells(i + r - (d - 1) Mod 7 - 1, 1), Cells(i + r - 1, 1)).EntireRow.Hidden = True
    
43.       End If
    
44.    Next
    
45.    Application.ScreenUpdating = True
    
46. End Sub

复制代码