层层相加的问题

Qs18

1. Sub qs()
   
2.     Application.ScreenUpdating = False: Application.DisplayAlerts = False
   
3.     Dim arr, i, wb As Workbook, xb As Workbook
   
4.         Dim FileName
   
5.     Set wb = ThisWorkbook
   
6.     FileName = Application.GetOpenFilename(FileFilter:="Excel 工作簿文件 (*.xls*),*.xls*", Title:="请选择文件", MultiSelect:=True)
   
7.     If Not IsArray(FileName) Then
   
8.         MsgBox "没有选择文件"
   
9.         Exit Sub
   
10.     End If
    
11.     For Each f In FileName
    
12.         Set xb = Workbooks.Open(f, 0)
    
13.                         
    
14.               arr = xb.Sheets(1).Range("a1").CurrentRegion
    
15.             ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
16.             For j = 1 To UBound(arr, 2)
    
17.             For i = 1 To UBound(arr) - 3
    
18.                 brr(i, j) = arr(i, j) + arr(i + 1, j) + arr(i + 2, j) + arr(i + 3, j)
    
19.             Next
    
20.             Next
    
21.             With xb.Sheets(2)
    
22.             .Range("a1").Resize(60000, UBound(arr, 2)).ClearContents
    
23.             .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
24.             End With
    
25. 
    
26.         xb.Close (1)
    
27.     Next f
    
28.     Application.ScreenUpdating = True: Application.DisplayAlerts = True
    
29. End Sub

复制代码

Qs18

试试。。。。。。。

Qs18

试试。。。。。。。。。

chxw68

修改好了。

杨小妹

chxw68 发表于 2024-9-8 16:56
修改好了。

谢谢老师！

cnmlgb9998

这样？？？？？？？？？？？？？？？？？？