历遍工作表减组数据的问题

杨小妹

附件 历遍工作表减组数据.rar (245.19 KB, 下载次数: 10)

2024-7-6 09:37 上传

点击文件名下载附件

谢谢老师！

titi012

参与 一下。。。。

1. Sub test()
   
2.     Dim Arr, i&, R&, Sh As Worksheet
   
3.     For Each Sh In ThisWorkbook.Sheets
   
4.         With xsh
   
5.             R = .Cells(Rows.Count, 2).End(xlUp).Row
   
6.             Arr = .Range("d1:e" & R)
   
7.             For i = 1 To R Step 3
   
8.                 Arr(i + 1, 2) = Arr(i, 1) - Arr(i + 1, 1)
   
9.             Next i
   
10.             .Range("d1:e" & R) = Arr
    
11.         End With
    
12.     Next Sh
    
13. End Sub

复制代码

kyxfyzg

Sub aa()
Dim sh As Worksheet, i
For Each sh In Worksheets
    For i = 1 To sh.UsedRange.Rows.Count + 1 Step 3
        sh.Cells(i + 1, 5) = sh.Cells(i, 4) - sh.Cells(i + 1, 4)
    Next i
Next sh
End Sub

feilanga

1. Sub tq()
   
2.     Dim sht As Worksheet
   
3.     For Each sht In Sheets
   
4.         With sht
   
5.             r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
6.             arr = .Range("a1").Resize(r, 4)
   
7.             For i = 1 To UBound(arr) Step 3
   
8.                 cz = arr(i, 4) - arr(i + 1, 4)
   
9.                 .Cells(i + 1, 6) = cz
   
10.             Next
    
11.         End With
    
12.     Next
    
13. End Sub

复制代码

feilanga

............

Qs18

Public Sub qs() '2024/7/6
    Dim arr, sht As Worksheet
    For Each sht In Sheets
        If sht.Name <> "Sheet0" Then
            arr = sht.Range("b1:e" & Sheet1.Cells(Rows.Count, 2).End(3).Row)
            For i = 2 To UBound(arr)
                If arr(i, 3) <> Empty And arr(i - 1, 3) <> Empty Then
                    arr(i, 4) = arr(i, 3) - arr(i - 1, 3)
                End If
            Next
            With Sheet6
                If .Range("b1") = "" Then
                    .Range("b1").Resize(UBound(arr), 4) = arr
                Else
                    rw = .Cells(Rows.Count, "d").End(3).Row + 2
                    .Range("b" & rw).Resize(UBound(arr), 4) = arr
                End If
            End With
        End If
    Next
End Sub

Qs18

试试................

Qs18

试试..........

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&, r&, wks As Worksheet
   
    Application.ScreenUpdating = False
   
    For Each wks In Worksheets
        If wks.Name <> "Sheet0" Then
            With wks
                r = .Cells(.Rows.Count, "B").End(xlUp).Row
                ar = .Range("B1:D" & r).Value
                ReDim br(1 To UBound(ar), 0)
                For i = 1 To UBound(ar) Step 3
                     br(i + 1, 0) = ar(i, 3) - ar(i + 1, 3)
                Next i
                .[E1].Resize(UBound(br)) = br
            End With
        End If
    Next
        
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

.................