[已解决]汇总分表数据到总表

oldwang

大佬们，我想把表1 2 3的B:F列数据按照从上到下从左到右的顺序平均分配汇总到表“总”的1、4列，求大佬写个代码我学习学习。

最佳答案

月排行榜 / 总排行榜

心正意诚身修

2021-11-10 11:22

1. Sub 宏2()
   
2. Dim ws As Worksheet
   
3. Dim i%, arr(1 To 1, 1 To 200), x%, j%, K%, L%, S As Integer, M, N
   
4. For i = 1 To Sheets.Count
   
5. If Sheets(i).Name <> "总" Then
   
6.     S = Sheets(i).UsedRange.Rows.Count
   
7.     For M = 1 To S
   
8.     For N = 2 To 6
   
9.            If Len(Sheets(i).Cells(M, N)) > 0 Then
   
10.         j = j + 1
    
11.         arr(1, j) = Sheets(i).Cells(M, N)
    
12.         End If
    
13.         Next
    
14.         
    
15.     Next
    
16. End If
    
17. Next
    
18.         For K = 1 To Int((j + 1) / 2)
    
19.             Cells(K, 1) = arr(1, K)
    
20.         Next
    
21.         For L = K To j
    
22.             Cells(L - K + 1, 4) = arr(1, L)
    
23.         Next
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

我感觉 你原来的思路有BUG，当周边有其他数据的时候，就会把不相干 周边的列的内容给导过来。所以我重新换了一种思路

跳转到最佳答案楼层

心正意诚身修

1. Sub 宏1()
   
2. Dim ws As Worksheet
   
3. Dim i%, arr(1 To 1, 1 To 200), x%, j%, K%, L%
   
4. For i = 1 To Sheets.Count
   
5. If Sheets(i).Name <> "总" Then
   
6.     Set rn = Sheets(i).UsedRange.Offset(0, 1).SpecialCells(xlCellTypeConstants, 23)
   
7.     x = x + rn.Cells.Count / 2
   
8.         End If
   
9.     Next
   
10.       If x - Int(x) >= 0 Then x = Int(x) + 1
    
11.     y = 0
    
12.     c = 1
    
13.     Application.ScreenUpdating = False
    
14.     For i = 2 To Sheets.Count
    
15. If Sheets(i).Name <> "总" Then
    
16.     For Each Rng In Sheets(i).UsedRange.Offset(0, 1)
    
17.         If Len(Rng) > 0 Then
    
18.         j = j + 1
    
19.         arr(1, j) = Rng
    
20.         End If
    
21.         Next
    
22.         End If
    
23.     Next
    
24.         For K = 1 To x - 1
    
25.             Cells(K, 1) = arr(1, K)
    
26.         Next
    
27.         For L = K To K * 2
    
28.             Cells(L - K + 1, 4) = arr(1, L)
    
29.         Next
    
30.     Application.ScreenUpdating = True
    
31. End Sub
    

复制代码

我用你原来的思路，在你原来的基础上修改的。
见附件

心正意诚身修

1. Sub 宏2()
   
2. Dim ws As Worksheet
   
3. Dim i%, arr(1 To 1, 1 To 200), x%, j%, K%, L%, S As Integer, M, N
   
4. For i = 1 To Sheets.Count
   
5. If Sheets(i).Name <> "总" Then
   
6.     S = Sheets(i).UsedRange.Rows.Count
   
7.     For M = 1 To S
   
8.     For N = 2 To 6
   
9.            If Len(Sheets(i).Cells(M, N)) > 0 Then
   
10.         j = j + 1
    
11.         arr(1, j) = Sheets(i).Cells(M, N)
    
12.         End If
    
13.         Next
    
14.         
    
15.     Next
    
16. End If
    
17. Next
    
18.         For K = 1 To Int((j + 1) / 2)
    
19.             Cells(K, 1) = arr(1, K)
    
20.         Next
    
21.         For L = K To j
    
22.             Cells(L - K + 1, 4) = arr(1, L)
    
23.         Next
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

我感觉 你原来的思路有BUG，当周边有其他数据的时候，就会把不相干 周边的列的内容给导过来。所以我重新换了一种思路

cutecpu

Sub demo()
   Cells.ClearContents
   For sh = 2 To Sheets.Count
      For Each Rng In Sheets(sh).UsedRange.Offset(, 1)
         If Rng.Value <> "" Then [a1].Offset(r) = Rng: r = r + 1
      Next
   Next
   [a1].Offset((r + 1) \ 2).Resize(r / 2).Cut [f1]
End Sub


祝順心，南無阿彌陀佛！

oldwang

心正意诚身修 发表于 2021-11-10 11:22
我感觉 你原来的思路有BUG，当周边有其他数据的时候，就会把不相干 周边的列的内容给导过来。所以我重新 ...

感谢大佬，你这种很好

oldwang

cutecpu 发表于 2021-11-10 12:04
Sub demo()
   Cells.ClearContents
   For sh = 2 To Sheets.Count

感谢大佬，简洁有效