[Nhờ giúp đỡ] Vòng lập giữa các row có màu

[dragonsworld]

Chào các pro,
Em là newbie nhờ các pro giúp em cú pháp VBA tự động cộng giá trị ở cột ở giữa 2 row màu vàng.
Ở đây là N7=sum(N7:N56) và N57=sum(N58:N101) ...
.
Em xin cảm ơn ạ.


.

 

[Hamedanger]

Bạn nghĩ phương án này cũng đơn giản và chân phương, bạn thử xem nhé
1.Chạy 1 vòng lặp qua bảng tính lấy các dòng tô màu đưa vào một cái mảng 1 chiều
2. Chạy 1 vòng lặp nữa qua mảng một chiều có được rồi gắn công thức vào Cell
Chú ý chia ra các trường hợp :
- Nếu chỉ có một ô được tô màu thì quá đơn giản rồi
- Nếu có nhiều hơn 1 ô thì chỉ chạy vòng lặp qua mảng một chiều từ phần tử đầu tiên đến phần tử gần cuối , còn phần tử cuối cùng để ngoài công thức và gắn công thức riêng.

 

[HUONGHCKT]

Chào các pro,
Em là newbie nhờ các pro giúp em cú pháp VBA tự động cộng giá trị ở cột ở giữa 2 row màu vàng.
Ở đây là N7=sum(N7:N56) và N57=sum(N58:N101) ...
(File đính kèm)
Em xin cảm ơn ạ.

View attachment 264047

Dùng thử đoạn code củ chuối này xem sao. may chăng cũng giải quyết được

Public Sub TinhTong()
Dim i&, Lr&, S()
With Sheet12
    Lr = .Cells(Rows.Count, 3).End(xlUp).Row
    ReDim S(1 To Lr, 1 To 1)
    For i = 1 To Lr
        If .Cells(i, 14).Interior.Color = 65535 Then
        t = t + 1
        S(t, 1) = i
        End If
    Next
    For j = 1 To t
        If S(j + 1, 1) <> Empty Then
                .Cells(S(j, 1), 14) = Application.Sum(.Range(.Cells(S(j, 1) + 1, 14), .Cells(S(j + 1, 1) - 1, 14)))
        Else
                .Cells(S(j, 1), 14) = Application.Sum(.Range(.Cells(S(j, 1) + 1, 14), .Cells(Lr, 14)))
        End If
    Next j
        
End With
End Sub
[code]

 

[SA_DQ]

Thêm 1 cách củ khoai khác vị xíu:

Sub TinhTongTheoDeMuc()
 Const Alf As String = "ABCDEFGHIJKLMNOPQRTSUVWXYZ_GPE.COM"
 Dim Rng As Range, sRng As Range
 Dim fRw As Long, lRw As Long, W As Integer, Rws As Long
 
 Rws = [A65500].End(xlUp).Row - 1
 Set Rng = Range([A6], Cells(Rws, "A")):       'MsgBox Rng.Address '
 For W = 1 To Len(Alf)
    Set sRng = Rng.Find(Mid(Alf, W, 1), , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        TTong Cells(fRw, "N"), Rws - fRw
        Exit For
    Else
        If fRw < 1 Then
            fRw = sRng.Row
        Else
            TTong Cells(fRw, "N"), sRng.Row - fRw
            fRw = sRng.Row
        End If
    End If
 Next W
 MsgBox "Chúc Vui Nha!", , "GPE.COM"
End Sub

Sub TTong(Rng As Range, Resiz As Integer)
    Rng.Select
    ActiveCell.FormulaR1C1 = "=SUM(R[1]C:R[" & Resiz & "]C)"       'R[1]C:R[49]C    '
End Sub

 

[ptm0412]

Thế này mới gọi là đơn giản:

Sub CalcSum()
Dim LastRw As Long
With Sheet12
    LastRw = .[C10000].End(xlUp).Row
    For i = LastRw To 7 Step -1
        If .Cells(i, 14).Interior.Color = 65535 Then
            .Cells(i, 14).FormulaR1C1 = "=sum(R[1]C:R[" & LastRw - i & "]C)"
            LastRw = i - 1
        End If
    Next
End With
End Sub

 

[Cá ngừ F1]

Thêm 1 cách củ khoai khác vị xíu:

Sub TinhTongTheoDeMuc()
 Const Alf As String = "ABCDEFGHIJKLMNOPQRTSUVWXYZ_GPE.COM"
 Dim Rng As Range, sRng As Range
 Dim fRw As Long, lRw As Long, W As Integer, Rws As Long
 
 Rws = [A65500].End(xlUp).Row - 1
 Set Rng = Range([A6], Cells(Rws, "A")):       'MsgBox Rng.Address '
 For W = 1 To Len(Alf)
    Set sRng = Rng.Find(Mid(Alf, W, 1), , xlFormulas, xlWhole)
    If sRng Is Nothing Then
        TTong Cells(fRw, "N"), Rws - fRw
        Exit For
    Else
        If fRw < 1 Then
            fRw = sRng.Row
        Else
            TTong Cells(fRw, "N"), sRng.Row - fRw
            fRw = sRng.Row
        End If
    End If
 Next W
 MsgBox "Chúc Vui Nha!", , "GPE.COM"
End Sub

Sub TTong(Rng As Range, Resiz As Integer)
    Rng.Select
    ActiveCell.FormulaR1C1 = "=SUM(R[1]C:R[" & Resiz & "]C)"       'R[1]C:R[49]C    '
End Sub

Phương phức tìm kiếm Find của bác Xa đúng là hàng khủng.

 

[dragonsworld]

Thêm 1 cách củ khoai khác vị xíu:

Sub TinhTongTheoDeMuc()
Sub TTong(Rng As Range, Resiz As Integer)
End Sub[/code]
[/QUOTE]

.

Quá kinh khủng,
Tuyệt vời! em không biết phải nói gì.
Chân thành cảm ơn các bác, đặc biệt là bác SA_DQ