Điều chỉnh số dòng theo thông tin nhập vào-Nhờ giúp đỡ sửa code VBA

Trạng thái
Không mở trả lời sau này.

iWATER

Yêu THVBA
Xin chào các bạn, mình có file excel sau gặp phải vấn đề về code, mong các bạn giúp đỡ.
Cũng xin được nói trước là mình áp dụng code này từ file khác sang nên mới phát sinh lỗi.

Giá trị ở các ô L2, L3 và L4 là số dòng tương ứng ở phần I, II và III.
Với Phần I và II thì không có vấn đề gì, nhưng phần III có lỗi phát sinh khi thay đổi giá trị ở ô L4.
Lỗi phát sinh đặc biệt rõ ràng sau khi thay đổi từ L4=0 thành giá trị khác.
Cám ơn các bạn nhiều

 

NhanSu

SMod
Thành viên BQT
@iWATER bạn cần up vài hình lên xem lỗi như thế nào, chương trình của bạn cần kết quả ra sao thì đúng?
 

iWATER

Yêu THVBA
Cám ơn bạn @NhanSu , mình gửi ảnh báo lỗi như sau:
1. Ảnh miêu tả lỗi
Bạn cần đăng nhập để thấy hình ảnh


2. Ảnh động

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


3. Phần code

Mã:
Option Explicit

Sub Test()
Dim wb As Workbook, sn As Worksheet, sd As Worksheet
Dim lrn As Long, lr1 As Long, lr2 As Long, i As Long, j As Long, k As Long
Set wb = ThisWorkbook
Set sn = wb.Sheets("TDCN_CG")
Application.ScreenUpdating = False
On Error Resume Next
With sn
        lrn = .Cells(Rows.Count, 2).End(xlUp).Row
        k = 2
        For i = 10 To lrn
            lr1 = .Range(Cells(i, 3), Cells(lrn, 3)).Find(what:="Chuyên gia 1").Row
                lr2 = .Cells(lr1, 4).End(xlDown).Row
                For j = lr2 To lr1 Step -1
                    If .Cells(lr1 + 1, 4) = "" Then Exit For
                    If lr2 + 1 - lr1 = .Cells(k, 12) Then Exit For
                    If lr2 + 1 - lr1 > .Cells(k, 12) Then
                        .Rows(j).EntireRow.Delete
                        lr2 = .Cells(lr1, 4).End(xlDown).Row
                    End If
                Next
                i = lr2 - 2
                k = k + 1
                If k > 4 Then Exit For
            lrn = .Cells(Rows.Count, 2).End(xlUp).Row
            If lr2 = lrn Then Exit For
        Next
        
        lrn = .Cells(Rows.Count, 2).End(xlUp).Row + 1
        k = 2
        For i = 10 To lrn
            lr1 = .Range(Cells(i, 3), Cells(lrn, 3)).Find(what:="Chuyên gia 1").Row
            lr2 = .Range(Cells(lr1, 3), Cells(lrn, 3)).Find(what:="B").Row
            If lr2 < lr1 Then lr2 = lrn
                For j = lr2 To lr1 + .Cells(k, 12) - 1
                        If lr2 - lr1 = .Cells(k, 12) Then Exit For
                            If lr2 - lr1 < .Cells(k, 12) Then
                                .Rows(j).EntireRow.Insert
                                .Cells(j, 5).FillDown
                                .Cells(j, 6).FillDown
                                .Cells(j, 7).FillDown
                                .Cells(j, 8).FillDown
                                .Cells(j, 9).FillDown
                                .Cells(j, 2) = .Cells(j - 1, 2) + 1
                                .Cells(j, 3) = .Cells(10, 3) & " " & Right(.Cells(j, 2), 1)
                                .Cells(j, 4) = .Cells(j - 1, 4)
                                lr2 = .Range(Cells(lr1, 3), Cells(lrn, 3)).Find(what:="B").Row
                            End If
                Next
                                i = lr2 - 1
                                k = k + 1
                                If k > 4 Then Exit For
                                lrn = .Cells(Rows.Count, 2).End(xlUp).Row
                                If lr2 = lrn Then Exit For
        Next
End With
Application.ScreenUpdating = True
End Sub
Nhờ bạn trợ giúp, cám ơn nhiều.
 

NhanSu

SMod
Thành viên BQT
Mình đã di chuyển bài viết vào mục hỏi đáp cũ.
Mình viết lại toàn bộ code cho nhanh, chỉ xét trường hợp 3 bộ phận có ít nhất 1 dòng, nếu không có dòng nào thì không có dữ liệu để copy. Sub Worksheet_Change nên thêm lệnh tắt sự kiện để tránh gọi lại nhiều lần dẫn đến kết quả sai. Mình cũng sửa lại công thức tính tổng để tự thay đổi theo số dòng và bổ sung các dấu chấm trước Cells.
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    If Not Intersect(Target, Range("L2:L4")) Is Nothing Then abc
    Application.EnableEvents = True
End Sub

Sub abc()
    Dim UpperRow&, LowerRow&, i&, n&, k&
    Dim sh As Worksheet
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set sh = ThisWorkbook.Sheets("TDCN_CG")
    n = 1000000
    With sh
        For i = 1 To 3
            k = .Cells(5 - i, 12).Value
            LowerRow = .Cells(n, 4).End(xlUp).Row
            If .Cells(LowerRow - 1, 4).Value = "" Then
                UpperRow = LowerRow
            Else
                UpperRow = .Cells(LowerRow, 4).End(xlUp).Row
            End If
           
            If k < LowerRow - UpperRow + 1 Then
                .Range(.Cells(UpperRow + k, 1), .Cells(LowerRow, 1)).EntireRow.Delete
            ElseIf k > LowerRow - UpperRow + 1 Then
                .Range(.Cells(LowerRow, 2), .Cells(LowerRow, 10)).Copy
                .Range(.Cells(LowerRow + 1, 2), .Cells(UpperRow + k - 1, 2)).Insert xlShiftDown
                .Range(.Cells(LowerRow, 2), .Cells(LowerRow, 3)).AutoFill .Range(.Cells(LowerRow, 2), .Cells(UpperRow + k - 1, 3)), xlFillSeries
            End If
            .Cells(UpperRow - 1, 9).FormulaR1C1 = "=SUM(R[1]C:R[" & k & "]C)"
            n = UpperRow - 1
           
        Next
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 

iWATER

Yêu THVBA
Cám ơn SMod @NhanSu đã giúp đỡ. Bạn có thể bổ sung trường hợp nếu L2, L3, L4=0 thì số hàng không thay đổi được không ạ?
 

tuhocvba

Administrator
Thành viên BQT
Bạn này có liên hệ code trả phí. Nhưng tôi từ chối. Tôi nghĩ sẽ tốt cho bạn hơn nếu bạn học cách trình bày cho chuyên nghiệp. Topic bên GPE người ta cũng chạy theo bạn ấy rất mệt mỏi.
Tôi không muốn topic này tiếp tục nữa. Tôi khóa topic này ở đây. Hãy học cách trình bày chuyên nghiệp, nêu nội dung câu hỏi đầy đủ, đừng lắt nhắt chèn thêm nội dung yêu cầu sau mỗi bài viết.
 

NhanSu

SMod
Thành viên BQT
Bạn thử chèn thêm lệnh sau vào sau dòng 17 ở code trên:
Mã:
If k=0 Goto Thoat
Bổ sung nhãn Thoat vào dòng 34 trên dòng Next:
Thoat:
 
Sửa lần cuối:
Trạng thái
Không mở trả lời sau này.
Top