Code Insert Row theo những con số cho trước. (1 người xem)

[LienDong]

Các bạn viết giúp code như sau:
Trong Sheet "YeuCau", dòng tiêu đề của mình là dòng 5
Bắt đầu từ dòng thứ 6 của cột H, nếu có số bao nhiêu thì Insert Row bấy nhiêu dòng! sau khi Insert Row xong thì xóa luôn các con số đó (lưu ý chỉ xóa số thôi chứ không xóa chuỗi là Text trong cột H)
Các bạn xem File đính kèm, Mình có làm kết qủa ở bên Sheet "KQ"
Xin cảm ơn cả nhà!
------------
Xin vui lòng lưu ý, dữ liệu các dòng trong Sheet "YeuCau" không liên tục!

 

[SA_DQ]

Them mà không fải thêm

Bạn thử nghiệm với cái này xem sao:

Option Explicit
Sub ThemDong()
 Dim Cls As Range:                                          Dim eRw As Long, jJ As Long
 
1 'Tìm Dòng Cuói Có Du Lieu:'
 eRw = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, _
    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
2 'Chuan Bi:'
 Columns("A:A").Insert
 [a5].Value = "TDe":                Cells(eRw, "A") = "GPE"
3 'Them Só Lieu Vo Cot A:'
 For Each Cls In Range("I6:I" & eRw)
    If IsNumeric(Cls.Value) Then
        For jJ = 1 To Cls.Value
            [a65500].End(xlUp).Offset(1).Value = "A" & Right("000" & Cls.Row, 4) & Right("00" & jJ, 3)
        Next jJ
    End If
    Cells(Cls.Row, "A").Value = "A" & Right("000" & Cls.Row, 4)
 Next Cls
4 'Xép Theo A:'
 [B5].CurrentRegion.Sort Key1:=Range("A6"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
5 'Tra Nguyen Trang Thái Dàu:'
 Columns("A:A").Select
 Selection.Delete Shift:=xlToLeft
End Sub

 

[Quang_Hải]

Các bạn viết giúp code như sau:
Trong Sheet "YeuCau", dòng tiêu đề của mình là dòng 5
Bắt đầu từ dòng thứ 6 của cột H, nếu có số bao nhiêu thì Insert Row bấy nhiêu dòng! sau khi Insert Row xong thì xóa luôn các con số đó (lưu ý chỉ xóa số thôi chứ không xóa chuỗi là Text trong cột H)
Các bạn xem File đính kèm, Mình có làm kết qủa ở bên Sheet "KQ"
Xin cảm ơn cả nhà!
------------
Xin vui lòng lưu ý, dữ liệu các dòng trong Sheet "YeuCau" không liên tục!

Đây là cách mình thường thêm dòng. Tuy nhiên nếu file bạn có công thức thì code này sai

Sub test_insert()
Dim data(), Res(1 To 10000, 1 To 14), X, k, i
data = Range([A6], [H65536].End(3).Offset(, 6)).Value
For i = 1 To UBound(data)
   If IsNumeric(data(i, 8)) Then
      k = k + data(i, 8) + 1
      For X = 1 To 14
         If X <> 8 Then Res(k, X) = data(i, X)
      Next
   Else
      k = k + 1
      For X = 1 To 14
         Res(k, X) = data(i, X)
      Next
   End If
Next
[A6].Resize(k, 14) = Res
End Sub

 

[LienDong]

Em thử code của hai anh thì thấy kết qủa như thế này ( đối với File đính kèm)
1/ Của anh SA_DQ: Em có cảm giác nó rút dòng lên chứ không fải chèn dòng, cụ thể dòng màu vàng đang ở dòng 17 , thêm 3 dòng thì sẽ là dòng 20 , nhưng cạy code lại thể hiện ở dòng 12!

2/ Của anh quanghai1969 thì xóa dòng chứ kg chèn dòng, ví dụ nó sẽ xóa các số 4,5,6 tại cột I (tương ứng nó xóa mất số liệu ở dòng 12, 13 & 14) và dòng màu vàng vẫn ở dòng 17 chứ kg đẩy xuống dòng 20

Các anh giúp em sửa code để nó giống như trang "Sau khi chạy code", xin lưu ý là dữ liệu của em sẽ có các dòng trống & không liên tục! Em cảm ơn cả nhà!

 

[Quang_Hải]

Em thử code của hai anh thì thấy kết qủa như thế này ( đối với File đính kèm)
1/ Của anh SA_DQ: Em có cảm giác nó rút dòng lên chứ không fải chèn dòng, cụ thể dòng màu vàng đang ở dòng 17 , thêm 3 dòng thì sẽ là dòng 20 , nhưng cạy code lại thể hiện ở dòng 12!

2/ Của anh quanghai1969 thì xóa dòng chứ kg chèn dòng, ví dụ nó sẽ xóa các số 4,5,6 tại cột I (tương ứng nó xóa mất số liệu ở dòng 12, 13 & 14) và dòng màu vàng vẫn ở dòng 17 chứ kg đẩy xuống dòng 20

Các anh giúp em sửa code để nó giống như trang "Sau khi chạy code", xin lưu ý là dữ liệu của em sẽ có các dòng trống & không liên tục! Em cảm ơn cả nhà!

Code chạy sai là do bạn gởi dữ liệu không thật nên mơi thế, chẳng biết được cột nào chuẩn để làm điểm tựa. Thôi thì cứ lấy tới dòng 1000
Khi cần bạn chỉnh lại dòng này data = [A6:N1000].Value

Sub test_insert()
Dim data(), Res(1 To 10000, 1 To 14), X, k, i
data = [A6:N1000].Value
For i = 1 To UBound(data)
   If IsNumeric(data(i, 8)) Then
      k = k + data(i, 8) + 1
      For X = 1 To 14
         If X <> 8 Then Res(k, X) = data(i, X)
      Next
   Else
      k = k + 1
      For X = 1 To 14
         Res(k, X) = data(i, X)
      Next
   End If
Next
[A6].Resize(k, 14) = Res
End Sub

 

[ChanhTQ@]

Khà, khà, biết ngay mà!

Code của SA_DQ có xác định dòng cuối chứa dữ liệu;

Nên tác giả topic xem lại lần nữa . . . . .