用VB把几张表的内容汇总一块

chzsh

不知道是不是符合要求，先参与一下

sxbjzjf110

参与一下

sxbjzjf110

参与一下，不知是否符合要求。

caiyu93

1. Sub Main()
   
2.     On Error Resume Next
   
3.     Dim sht As Worksheet
   
4.     Dim pend As Worksheet
   
5.     Application.DisplayAlerts = 0
   
6.     Sheets("汇总").Delete
   
7.     Set pend = Sheets("汇总")
   
8.     Application.ScreenUpdating = 0
   
9.     If Err.Number <> 0 Then
   
10.         Set pend = Sheets.Add
    
11.         pend.Name = "汇总"
    
12.         pend.Move Sheets(1)
    
13.     End If
    
14.     On Error GoTo 0
    
15.     Dim r As Range, used As Range, cur As Range, f As Range
    
16.     Dim n%, j%, total As Range
    
17.     n = Sheets.Count
    
18.     Set r = pend.Range("a3")
    
19.     For i% = 1 To n
    
20.         If Sheets(i).Name <> pend.Name Then
    
21.             If j > 6 Then Exit For
    
22.             Set sht = Sheets(i)
    
23.             Set used = sht.UsedRange
    
24.             Set f = used.Find("*", SearchDirection:=xlPrevious)
    
25.             Set cur = sht.Range(Cells(3, 1), _
    
26.                 Cells(f.Row - 1, f.Column))
    
27.             Set total = sht.Range(Cells(f.Row, 1), Cells(f.Row, f.Column))
    
28.             If pend.UsedRange.Count = 1 Then
    
29.                 cur.Copy r
    
30.             Else
    
31.                 cur.Copy Cells(pend.UsedRange.Find("*", SearchDirection:=xlPrevious).Row, 1)
    
32.             End If
    
33.         End If
    
34.         j = j + 1
    
35.     Next
    
36.     Set r = Sheets(2).Range("1:2")
    
37.     r.Copy pend.Range("a1")
    
38.     Set used = pend.UsedRange
    
39.     Set used = pend.Range(used(2), used.Resize(used.Rows.Count))
    
40.     used.EntireColumn.AutoFit
    
41.     Set used = pend.Range(Range("a3"), Cells(used.Rows.Count, used.Columns.Count))
    
42.     used.Borders.LineStyle = 1
    
43.     If ActiveSheet.Name = pend.Name Then [a1].Select
    
44.     Set used = pend.UsedRange
    
45.     Set f = pend.Range(Cells(used.Rows.Count, 1), Cells(used.Rows.Count, used.Columns.Count))
    
46.     total.Copy f
    
47.     Application.ScreenUpdating = 1
    
48.     '学习交流群: 223198032
    
49. End Sub

复制代码

最后的公式统计自己看着处理吧

caiyu93

caiyu93

3190496160

cjc209 发表于 2023-2-10 18:01
你是猜的吧 万一他不是这个意思 又瞎忙活了

你每次回帖都是百分之百的把握吗？

zengpeng781225

caiyu93 发表于 2023-2-10 21:44
最后的公式统计自己看着处理吧

谢谢，我试试先