汇总各工作表数据的问题

杨小妹

附件 汇总各工作表数据.rar (228.09 KB, 下载次数: 12)

2024-7-16 16:44 上传

点击文件名下载附件

谢谢老师！

cidanji

ykcbf1100

工作表合并，供参考。。。

ykcbf1100

工作表合并

1. Sub ykcbf()   '//2024.7.16  工作表合并
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("Sheet0")
   
4.     ReDim brr(1 To 100000, 1 To 6)
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             With sht
   
8.                 r = .Cells(Rows.Count, 1).End(3).Row
   
9.                 arr = .[a1].Resize(r + 1, 5)
   
10.                 For i = 1 To UBound(arr) Step 3
    
11.                     m = m + 3
    
12.                     For j = 1 To UBound(arr, 2)
    
13.                         brr(m - 2, j) = arr(i, j)
    
14.                         brr(m - 1, j) = arr(i + 1, j)
    
15.                     Next
    
16.                     brr(m - 1, 6) = .Name
    
17.                 Next
    
18.             End With
    
19.         End If
    
20.     Next
    
21.     With sh
    
22.         .[a:f] = ""
    
23.         .[a1].Resize(m, 6) = brr
    
24.     End With
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    
28. 
    

复制代码

Qs18

Sub qs() '2024/7/16
    Dim sht As Worksheet, arr, i
    For Each sht In Sheets
        If sht.Name <> "Sheet0" Then
            arr = sht.Range("a1:f" & sht.Cells(Rows.Count, 1).End(3).Row)
            For i = 1 To UBound(arr)
                If arr(i, 5) <> Empty Then arr(i, 6) = sht.Name
            Next
            With Sheet1
                If .Range("a1") = "" Then
                    .Range("a1").Resize(UBound(arr), UBound(arr, 2)) = arr
                Else
                    .Range("a" & .Cells(Rows.Count, 1).End(3).Row + 2).Resize(UBound(arr), UBound(arr, 2)) = arr
                End If
               
            End With
        End If
    Next
    MsgBox "完成！"
End Sub

Qs18

请测试................

Qs18

请测试..............