Nhờ code hiệu chỉnh dữ liệu

[SoGoKu7]

Xin chào anh/chị
hiện em đang có vấn đề về việc hiệu chỉnh dữ liệu nhưng chưa làm được. Nhờ anh/chị ghé qua và giúp em với ạ

Nhờ anh/chị code dùm để được kết quả như phía dưới theo quy luật sau

trong 1 tuần thì tính tổng số lượng từ ngày đầu tiên đến ngày có số lượng >=5000

Những ngày còn lại trong tuần đó sẽ chuyển thành 0

vi dụ: sản phẩm A tuần thứ 45 có tổng từ ngày 1/11-->5/11 là : 433+1196+1125+221+2287 = 5262 nên ngày 5/11 sẽ chuyển về 0

luc này tuần thứ 45 sẽ còn 433+1196+1125+221+0 ạ

Kết quả mong muốn

Xin chân thành cảm ơn anh/chị nhiều ạ

 

[snow25]

Xin chào anh/chị
hiện em đang có vấn đề về việc hiệu chỉnh dữ liệu nhưng chưa làm được. Nhờ anh/chị ghé qua và giúp em với ạ
View attachment 284336

Nhờ anh/chị code dùm để được kết quả như phía dưới theo quy luật sau

trong 1 tuần thì tính tổng số lượng từ ngày đầu tiên đến ngày có số lượng >=5000

Những ngày còn lại trong tuần đó sẽ chuyển thành 0

vi dụ: sản phẩm A tuần thứ 45 có tổng từ ngày 1/11-->5/11 là : 433+1196+1125+221+2287 = 5262 nên ngày 5/11 sẽ chuyển về 0

luc này tuần thứ 45 sẽ còn 433+1196+1125+221+0 ạ

Kết quả mong muốn

Xin chân thành cảm ơn anh/chị nhiều ạ

Thử code sau kết quả bên sheet2

Sub abc()
    Dim i As Long, lr As Long, arr, j As Long, tong As Double
    With Sheets("sheet1")
        arr = .Range("B1:AF21").Value
        For i = 3 To UBound(arr)
            For j = 2 To UBound(arr, 2)
                If arr(1, j) = arr(1, j - 1) Then
                    tong = tong + arr(i, j)
                Else
                   tong = arr(i, j)
                End If
                   If tong > 5000 Then
                      arr(i, j) = 0
                   End If
           Next j
      Next i
    End With
    With Sheet2
         .Range("B1:AF21").Value = arr
    End With
End Sub

 

[SoGoKu7]

Thử code sau kết quả bên sheet2

Sub abc()
    Dim i As Long, lr As Long, arr, j As Long, tong As Double
    With Sheets("sheet1")
        arr = .Range("B1:AF21").Value
        For i = 3 To UBound(arr)
            For j = 2 To UBound(arr, 2)
                If arr(1, j) = arr(1, j - 1) Then
                    tong = tong + arr(i, j)
                Else
                   tong = arr(i, j)
                End If
                   If tong > 5000 Then
                      arr(i, j) = 0
                   End If
           Next j
      Next i
    End With
    With Sheet2
         .Range("B1:AF21").Value = arr
    End With
End Sub

Tuyệt vời quá anh ơi, trúng rồi ạ!
Cảm ơn anh lắm lắm nhé!

 

[bebo021999]

Góp vui
Click vào nút "RUN". Kết quả sẽ nằm tại sheet "KETQUA" nhé

Option Explicit
Sub test()
Dim lr&, i&, j&, lc&
Dim sum As Long, rng, res()
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    lc = .Cells(2, Columns.Count).End(xlToLeft).Column
    rng = .Range("B1", .Cells(lr, lc)).Value
    Sheets("Sheet1").Copy after:=Sheets("Sheet1")
End With
If Evaluate("=ISREF(KetQua!A1)") Then Sheets("KetQua").Delete
ActiveSheet.Name = "KetQua"
ReDim res(1 To UBound(rng) - 2, 1 To UBound(rng, 2) - 1)
For i = 3 To UBound(rng)
    For j = 2 To UBound(rng, 2)
        sum = IIf(rng(1, j) <> rng(1, j - 1), 0, sum) + rng(i, j)
        If sum < 5000 Then res(i - 2, j - 1) = rng(i, j)
    Next
Next
Range("C3:AX10000").ClearContents
Range("C3").Resize(UBound(res), UBound(res, 2)).Value = res
End Sub

 

[SoGoKu7]

Góp vui
Click vào nút "RUN". Kết quả sẽ nằm tại sheet "KETQUA" nhé

Option Explicit
Sub test()
Dim lr&, i&, j&, lc&
Dim sum As Long, rng, res()
With Sheets("Sheet1")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    lc = .Cells(2, Columns.Count).End(xlToLeft).Column
    rng = .Range("B1", .Cells(lr, lc)).Value
    Sheets("Sheet1").Copy after:=Sheets("Sheet1")
End With
If Evaluate("=ISREF(KetQua!A1)") Then Sheets("KetQua").Delete
ActiveSheet.Name = "KetQua"
ReDim res(1 To UBound(rng) - 2, 1 To UBound(rng, 2) - 1)
For i = 3 To UBound(rng)
    For j = 2 To UBound(rng, 2)
        sum = IIf(rng(1, j) <> rng(1, j - 1), 0, sum) + rng(i, j)
        If sum < 5000 Then res(i - 2, j - 1) = rng(i, j)
    Next
Next
Range("C3:AX10000").ClearContents
Range("C3").Resize(UBound(res), UBound(res, 2)).Value = res
End Sub

Em cảm ơn anh nhiều ạ!