Giãn dòng và chèn công thức SUM

hocmoi · 26/4/20

Mã:

Sub Tong() 'Tinh tong cho 2 gia tri tro len
Dim cend As Long, iCol As Long
Dim i As Long
Dim j As Long

Application.ScreenUpdating = False
i = 8
j = i
cend = Cells(6, Columns.Count).End(xlToLeft).Column

Do While Range("A" & i) <> ""
    If Range("A" & i) <> Range("A" & (i + 1)) Then
       Rows(i + 1).Insert
       Range("A" & (i + 1)) = Range("A" & i).Value
            For iCol = 2 To cend
                Cells(i + 1, iCol).Formula = "=SUM(R" & j & "C:R" & i & "C)"
            Next iCol
                Range(Cells(i + 1, 1), Cells(i + 1, cend)).Font.Bold = True
                Range(Cells(i + 1, 1), Cells(i + 1, cend)) = Range(Cells(i + 1, 1), Cells(i + 1, cend)).Value
                With Range(Cells(i + 1, 1), Cells(i + 1, cend)).Select
                     Selection.Interior.Color = 65535
                End With
                i = i + 2
                j = i
        Else
        i = i + 1
    End If
Loop
Application.ScreenUpdating = True
End Sub

Xin chào diễn đàn,
Mình có đoạn Code " lượm lặt về chỉnh theo ý mình" nhưng khả năng Code chưa có nên khi chạy Code thì không đúng theo ý, nhờ thành viên chỉnh dùm đoạn Code.
Đoạn Code của mình là khi thấy giữa 2 Acount khác nhau thì sẽ chèn thêm dòng và tính Sum ( hình 1) ---> giờ muốn chỉnh sửa lại là vẫn chèn thêm dòng và tính Sum nhưng nếu gặp 1 Acount thì không cần chèn thêm dòng, chỉ 2 Acount trở lên thì mới chèn thêm dòng va tính Sum , ( hình 2).
P/S: Do file này có thể demo nháp được nên mình không gửi đường link lấy file, các thành viên demo thử dùm nhé.

Bạn cần đăng nhập để thấy hình ảnh

Xin cám ơn các thành viên

vbano1 · 26/4/20

Điều rắc rối cho người code chính là ý tưởng thêm hàng, việc này sẽ làm thay đổi số lượng hàng vốn có cho người code. Mong muốn thay đổi ý tưởng thiết kế, nên hiển thị kết quả SUM như thế nào đấy không làm ảnh hưởng tới số lượng hàng vốn có thì tốt.
Trường hợp vẫn muốn giữ nguyên ý tưởng ban đầu thì vẫn code được, bạn tham khảo topic sau xem làm được không:

Bạn cần đăng nhập để thấy link

Trong trường hợp không làm được, hãy phản hồi lại trong topic này, chúng tôi sẽ hỗ trợ bạn.
Topic này bạn trình bày là dễ hiểu, đã biết sử dụng hình ảnh trực quan.

NhanSu · 26/4/20

Bạn sửa câu lệnh ở dòng 12 thành

Mã:

If Range("A" & i) <> Range("A" & (i + 1)) and i>j+1 Then

là được, vì bảng nhỏ nên vấn đề dùng mảng để cải thiện tốc độ không cần thiết. Câu lệnh ở dòng 16 hơi lạ, thường công thức này nên dùng thuộc tính FormulaR1C1

hocmoi · 26/4/20

NhanSu nói:
Bạn sửa câu lệnh ở dòng 12 thành

Mã:

If Range("A" & i) <> Range("A" & (i + 1)) and i>j+1 Then

là được, vì bảng nhỏ nên vấn đề dùng mảng để cải thiện tốc độ không cần thiết. Câu lệnh ở dòng 16 hơi lạ, thường công thức này nên dùng thuộc tính FormulaR1C1

Cám ơn bạn NhanSu, điều kiện ( and i >j+1) đó không áp dụng được bạn ah, Code sẽ bỏ dòng , ( như hình 2 là sẽ bỏ qua dòng 13, 14), hoặc trường hợp dòng 8 , nếu có 2 Acount giống nhau sẽ bỏ qua luôn.

BKKBG · 26/4/20

Bạn chủ topic từng ủng hộ diễn đàn thì phải.
Hãy cho phép tôi được hỗ trợ bạn.

Bước 1: Giãn dòng
Bước 2: Điền công thức vào các dòng trống.
Cách nghĩ rất đơn giản, dùng Do While làm gì nhỉ, tôi chỉ dùng for next như các quản trị viên đã dùng thôi.
Bạn thử:

Mã:

Sub tuhocvba0426()
    Dim i As Long, j As Long, rend As Long, rbd As Long, rkt As Long
    Dim cend    As Integer
    Const r1    As Long = 6
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    rend = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Dong cuoi cua cot A
    cend = ThisWorkbook.ActiveSheet.Cells(r1, Columns.Count).End(xlToLeft).Column
    If cend = 1 Then
        MsgBox "Khong co du lieu"
        Exit Sub
    End If
    If rend <= r1 Then
        MsgBox "Khong co du lieu"
        Exit Sub
    End If
    With ThisWorkbook.ActiveSheet
        For i = rend To r1 + 1 Step -1
            If .Cells(i, 1) <> "" And .Cells(i - 1, 1) <> "" And .Cells(i, 1) <> .Cells(i - 1, 1) Then
                .Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            End If
        Next i
    
    rend = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    'Ghi cong thuc
    For i = r1 + 1 To rend Step 1
        If .Cells(i, 1) <> "" And .Cells(i, 1) <> .Cells(i - 1, 1) Then rbd = i
        If .Cells(i, 1) <> "" And .Cells(i + 1, 1) = "" Then
            rkt = i
            For j = 2 To cend Step 1
                rbd = rbd - (i + 1)
                rkt = rkt - (i + 1)
                .Cells(i + 1, j).FormulaR1C1 = "=SUM(R[" & rbd & "]C:R[" & rkt & "]C)"
                .Cells(i + 1, 1) = .Cells(i, 1)
                .Range(Cells(i + 1, 1), Cells(i + 1, cend)).Font.Bold = True
            Next j
        End If
        
        
    Next
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Input:

Bạn cần đăng nhập để thấy hình ảnh

Output:

Bạn cần đăng nhập để thấy hình ảnh

NhanSu · 26/4/20

Mình cũng sửa lại code như sau

Mã:

Option Explicit
Sub Tong() 'Tinh tong cho 2 gia tri tro len
Dim cend As Long, iCol As Long
Dim i As Long
Dim j As Long

Application.ScreenUpdating = False
i = 8
j = i
cend = Cells(6, Columns.Count).End(xlToLeft).Column

Do While Range("A" & i) <> ""
    If Range("A" & i) <> Range("A" & (i + 1)) Then
        If i > j Then
            Rows(i + 1).Insert
            Range("A" & (i + 1)) = Range("A" & i).Value
            For iCol = 2 To cend
                Cells(i + 1, iCol).Formula = "=SUM(R" & j & "C:R" & i & "C)"
            Next iCol
            Range(Cells(i + 1, 1), Cells(i + 1, cend)).Font.Bold = True
            Range(Cells(i + 1, 1), Cells(i + 1, cend)) = Range(Cells(i + 1, 1), Cells(i + 1, cend)).Value
            With Range(Cells(i + 1, 1), Cells(i + 1, cend)).Select
                 Selection.Interior.Color = 65535
            End With
            i = i + 2
            j = i
        Else
            i = i + 1
            j = i
        End If
    Else
        i = i + 1
    End If
Loop
Application.ScreenUpdating = True
End Sub

Euler · 26/4/20

BKKBG nói:
Input:

Bạn cần đăng nhập để thấy hình ảnh

Output:

Bạn cần đăng nhập để thấy hình ảnh

Kết quả chưa ổn rồi. Mình sửa lại code cho bạn như sau:

Mã:

Sub tuhocvba0426()
    Dim i As Long, j As Long, rend As Long, rbd As Long, rkt As Long, rbd2 As Long, rkt2 As Long
    Dim cend    As Integer
    Const r1    As Long = 6
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    rend = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Dong cuoi cua cot A
    cend = ThisWorkbook.ActiveSheet.Cells(r1, Columns.Count).End(xlToLeft).Column
    If cend = 1 Then
        MsgBox "Khong co du lieu"
        Exit Sub
    End If
    If rend <= r1 Then
        MsgBox "Khong co du lieu"
        Exit Sub
    End If
    With ThisWorkbook.ActiveSheet
        For i = rend To r1 + 1 Step -1
            If .Cells(i, 1) <> "" And .Cells(i - 1, 1) <> "" And .Cells(i, 1) <> .Cells(i - 1, 1) Then
                .Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            End If
        Next i
    
    rend = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    'Ghi cong thuc
    For i = r1 + 1 To rend Step 1
        If .Cells(i, 1) <> "" And .Cells(i, 1) <> .Cells(i - 1, 1) Then rbd = i
        If .Cells(i, 1) <> "" And .Cells(i + 1, 1) = "" Then
            rkt = i
            For j = 2 To cend Step 1
                rbd2 = rbd - (i + 1)
                rkt2 = rkt - (i + 1)
                .Cells(i + 1, j).FormulaR1C1 = "=SUM(R[" & rbd2 & "]C:R[" & rkt2 & "]C)"
                .Cells(i + 1, 1) = .Cells(i, 1)
                .Range(Cells(i + 1, 1), Cells(i + 1, cend)).Font.Bold = True
            Next j
        End If
        
        
    Next
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Mình khai báo thêm cái này: rbd2 As Long, rkt2 As Long

Kết quả:
Input:

Bạn cần đăng nhập để thấy hình ảnh

Output:

Bạn cần đăng nhập để thấy hình ảnh

giaiphapvba · 26/4/20

@BKKBG : Bạn chủ topic nói là nếu chỉ có 1 acc thì không tạo lập SUM.
Code

Bạn cần đăng nhập để thấy link

và

Bạn cần đăng nhập để thấy link

sửa lại:

Mã:

Sub tuhocvba0426()
    Dim i As Long, j As Long, rend As Long, rbd As Long, rkt As Long, rbd2 As Long, rkt2 As Long
    Dim cend    As Integer
    Const r1    As Long = 6
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    rend = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row 'Dong cuoi cua cot A
    cend = ThisWorkbook.ActiveSheet.Cells(r1, Columns.Count).End(xlToLeft).Column
    If cend = 1 Then
        MsgBox "Khong co du lieu"
        Exit Sub
    End If
    If rend <= r1 Then
        MsgBox "Khong co du lieu"
        Exit Sub
    End If
    With ThisWorkbook.ActiveSheet
        For i = rend To r1 + 1 Step -1
            If .Cells(i, 1) <> "" And .Cells(i - 1, 1) <> "" And .Cells(i, 1) <> .Cells(i - 1, 1) Then
                .Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            End If
        Next i
    
    rend = ThisWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    'Ghi cong thuc
    For i = r1 + 1 To rend Step 1
        If .Cells(i, 1) <> "" And .Cells(i, 1) <> .Cells(i - 1, 1) Then rbd = i
        If .Cells(i, 1) <> "" And .Cells(i + 1, 1) = "" Then
            rkt = i
            If Not (rkt = rbd) Then
            For j = 2 To cend Step 1
                rbd2 = rbd - (i + 1)
                rkt2 = rkt - (i + 1)
                .Cells(i + 1, j).FormulaR1C1 = "=SUM(R[" & rbd2 & "]C:R[" & rkt2 & "]C)"
                .Cells(i + 1, 1) = .Cells(i, 1)
                .Range(Cells(i + 1, 1), Cells(i + 1, cend)).Font.Bold = True
            Next j
            End If
        End If
        
        
    Next
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

INPUT:

Bạn cần đăng nhập để thấy hình ảnh

OUTPUT:

Bạn cần đăng nhập để thấy hình ảnh

hocmoi · 26/4/20

NhanSu nói:

Mình cũng sửa lại code như sau

Mã:

Option Explicit
Sub Tong() 'Tinh tong cho 2 gia tri tro len
Dim cend As Long, iCol As Long
Dim i As Long
Dim j As Long

Application.ScreenUpdating = False
i = 8
j = i
cend = Cells(6, Columns.Count).End(xlToLeft).Column

Do While Range("A" & i) <> ""
    If Range("A" & i) <> Range("A" & (i + 1)) Then
        If i > j Then
            Rows(i + 1).Insert
            Range("A" & (i + 1)) = Range("A" & i).Value
            For iCol = 2 To cend
                Cells(i + 1, iCol).Formula = "=SUM(R" & j & "C:R" & i & "C)"
            Next iCol
            Range(Cells(i + 1, 1), Cells(i + 1, cend)).Font.Bold = True
            Range(Cells(i + 1, 1), Cells(i + 1, cend)) = Range(Cells(i + 1, 1), Cells(i + 1, cend)).Value
            With Range(Cells(i + 1, 1), Cells(i + 1, cend)).Select
                 Selection.Interior.Color = 65535
            End With
            i = i + 2
            j = i
        Else
            i = i + 1
            j = i
        End If
    Else
        i = i + 1
    End If
Loop
Application.ScreenUpdating = True
End Sub

Cám ơn bạn, Đúng điều kiện rồi bạn ơi.
CC: Mình cũng cám ơn các bạn khác đã Code cho mình nữa, và cho mình thêm điều kiện học hỏi, mình đang hiểu theo cái Code ban đầu của mình nên ưu tiên Code bạn NhanSu sửa cho mình. Code các bạn mình sẽ ghi nhận và tìm tòi thêm cách viết các Code đó.
Cám ơn tất cả.

giaiphapvba · 26/4/20

Cảm ơn bạn đã phản hồi. Bạn:
-Đã hỗ trợ diễn đàn tài chính.
-Đã trình bày yêu cầu dễ hiểu.
Do đó đã nhận được nhiều trợ giúp. Mong nhận được ủng hộ của bạn trong tương lai.
Cho phép tôi khóa topic này, tôi nhận thức rằng trợ giúp đã hoàn thành.

Giãn dòng và chèn công thức SUM

hocmoi

Yêu THVBA

vbano1

SMod

NhanSu

SMod

hocmoi

Yêu THVBA

BKKBG

Yêu THVBA nhất

NhanSu

SMod

Euler

Administrator

giaiphapvba

Administrator

hocmoi

Yêu THVBA

giaiphapvba

Administrator