层层相加的问题

杨小妹 · 发表于 2024-9-8 08:40

本帖最后由杨小妹于 2024-9-8 09:34 编辑

附件

层层相加附件.rar (401.92 KB, 下载次数: 14)

谢谢老师！

chxw68 · 发表于 2024-9-8 09:17

Sub test()
Dim r%, i%, c%, j%
Dim arr, brr
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
End With
ReDim brr(1 To UBound(arr) - 3, 1 To UBound(arr, 2))
For i = 1 To UBound(arr) - 3
For k = 1 To 4
For j = 1 To UBound(arr, 2)
brr(i, j) = brr(i, j) + arr(i + k - 1, j)
Next
Next
Next
With Worksheets("sheet2")
.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
End Sub

复制代码

chxw68 · 发表于 2024-9-8 09:17

非常简单的问题。

songshihai · 发表于 2024-9-8 09:34

灰常简单!!!!!!!!!!!!!!!!!!!!!!!!!!

杨小妹 · 发表于 2024-9-8 13:47

chxw68 发表于 2024-9-8 09:17
非常简单的问题。

老师你好，谢谢帮助。试了一下效果很好。实际运用中，因数据量较大，这样单个操作效率不高。因此想修改一下，不知能否麻烦一下？

改为：本附件与50个二进制格式的工作薄，在同一目录。

每个工作薄，在表1里，有50列数据，7000行。格式统一。

按上面的方法对工作薄各列，层层相加，结果返回到各放在各工作薄表2相应列。

附件

层层相加附件2.rar (763.91 KB, 下载次数: 7)

Qs18 · 发表于 2024-9-8 15:35

Sub qs()
Dim arr, i
arr = Sheet1.Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For j = 1 To UBound(arr, 2)
For i = 4 To UBound(arr)
brr(i, j) = arr(i, j) + arr(i - 1, j) + arr(i - 2, j) + arr(i - 3, j)
Next
Next
With Sheet2
.Range("a1").Resize(60000, UBound(arr, 2)).ClearContents
.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
.Range("a1:c3").Delete
End With
End Sub

复制代码

Qs18 · 发表于 2024-9-8 15:49

试试。。。。。。。。。。。。

Qs18 · 发表于 2024-9-8 15:50

试试。。。。。。。。。。。。

杨小妹 · 发表于 2024-9-8 15:55

Qs18 发表于 2024-9-8 15:50
试试。。。。。。。。。。。。

老师你好，谢谢帮助。5楼的附件是针对与附件同一目录的每个工作薄操作。不是针对附件中的三列操作。

Qs18 · 发表于 2024-9-8 15:59

杨小妹发表于 2024-9-8 15:55
老师你好，谢谢帮助。5楼的附件是针对与附件同一目录的每个工作薄操作。不是针对附件中的三列操作。

哦，我看看，就是代码要单独写在另外的工作簿才能满足您的要求

		自动登录	找回密码
密码			免费注册

[已解决] 层层相加的问题

评分