Nhờ giúp code tự động chèn thêm dòng bên trên (1 người xem)

[xucxich]

Em có bảng Định mức như ở file đính kèm (em chỉ để vài đầu việc cho nhẹ file up lên diẽn đàn cho tiện)
Em muốn các vật tư được phân tích bên dưới mỗi công việc sẽ được phân ra làm 3 loại: "Vật liệu", "Nhân công", "Máy thi công".
(Nghĩa là chèn thêm 1 dòng bên trên mỗi nhóm vật tư và điền vào đó "Vật liệu", "Nhân công" hay "Máy thi công")
Giống 3 các ô màu vàng em có làm ví dụ ở công việc cuối cùng trong file đính kèm.
Nhờ các anh giúp em đoạn code để có thể tự động làm công việc trên.
Vì trong định mức có đến hơn 50.000 dòng nên làm thủ công em ko biết khi nào xong

Mong các a giúp.
Em cảm ơn!

 

[SA_DQ]

Bạn kiểm theo file đúng chưa nha?

Sau khi kiểm tra, muốn chạy lại macro, bạn chép các cột có số liệu của trang 'Luu' sang & cho macro chạy là được;

 

[xucxich]

1 cái click mà nếu làm thủ công thì ...
cảm ơn a nhiều!

 

[xucxich]

Sau khi kiểm tra, muốn chạy lại macro, bạn chép các cột có số liệu của trang 'Luu' sang & cho macro chạy là được;

Khi e dùng code cho ít công việc thì code chạy tốt, còn khi dùng cho nhiều công việc như file đính kèm thì xuất hiện lỗi, và các đầu việc bên dưới cùng ko có dòng "Vật liệu"

Nhờ a hay bạn nào biết xem lại giúp!
Cảm ơn!

 

[SA_DQ]

Lỗi gây ra do dòng lệnh sau số 4 (xóa dữ liệu cột 'A')

Với macro sau chỉnh sửa này, máy mình chạy mất 2 fút; (Chạy trên máy bạn, số liệu sẽ được ghi đâu đó trên cột J:

Option Explicit
[B]Sub ChènDòng()
[/B] Dim Rng As Range, sRng As Range
 Dim Rws As Long, jJ As Byte, Tmr As Double
 Dim MyAdd As String, MHVT As String
1 'Them Só TT:'
 Sheets("DM").Select:                           Tmr = Timer()
 Rws = [C65535].End(xlUp).Row
 Application.ScreenUpdating = False
 With [A1]
    .Value = "A000001":                         .Select
    Selection.AutoFill Destination:=Range("A1:A" & Rws), Type:=xlFillDefault
 End With
 Set Rng = Range("C2:c" & Rws)
2 'Tìm & Ghi Tuong Úng:'
 For jJ = 1 To 3
    MHVT = Choose(jJ, "N", "M", "V") & ":"
    Set sRng = Rng.Find(MHVT, , xlFormulas, xlPart)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        MyAdd = sRng.Address
        Do
            If Left(sRng.Offset(-1).Value, 3) <> MHVT Then
                With [A65535].End(xlUp).Offset(1, 3)
                    .Offset(, -3).Value = sRng.Offset(-1, -2).Value & "9"
                    Select Case jJ
                    Case 1
                        .FormulaR1C1 = "=NC"
                    Case 2
                        .FormulaR1C1 = "=May"
                    Case 3
                        .FormulaR1C1 = "=VL"
                    End Select
                End With
            End If
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
    End If
 Next jJ
3 ' Sáp Xép Cot "A"':
 Columns("A:G").Select
 Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
4 'Xóa Noi Dung Cot "A":'
 Columns("A:A").Clear                            '|*|'
 Application.ScreenUpdating = True
5 Randomize
 [B1].Resize(, 6).Interior.ColorIndex = 34 + 9 * Rnd() \ 1
 [j2].Value = Timer() - Tmr
[B]End Sub[/B]

 

[xucxich]

mình nghĩ là do số dòng trong định mức sau khi thêm các dòng "VL, NC, M" vượt quá giới hạn số dòng cho phép của excel nên mới xảy ra lỗi.
Khi mình tách 2 Định mức ra để chạy code thì ko xảy ra lỗi nữa.
Cảm ơn các bạn đã giúp!

 

[SA_DQ]

Báo lỗi là do dòng lệnh này đó bạn

 [A1].Resize(2 * Rws).Clear

một khi Rws trên 3,3 vạn dòng (trong E2003)