Xin giúp đỡ code VBA chèn thêm dòng

[hieuhus]

Chào cả nhà.
Mình có bài toán như sau, mong mọi người giúp đỡ:
- Bảng dữ liệu ở cột A, B, C
- Số lượng dòng của mỗi 1 nhóm là cột I

Mình cần chèn thêm dòng vào sau mỗi 1 nhóm (cột A) để đủ số lượng cho trước (số lượng dòng cần thêm của mỗi nhóm là khác nhau).

Cảm ơn mọi người.

View attachment 292829

 

[VetMini]

Chào cả nhà.
Mình có bài toán như sau, mong mọi người giúp đỡ:
...

Bài toán này không có gì xa lạ hay mới mẻ cả. Nhiều người gặp rồi cho nên bài giải ở đây có cả đống.
Bạn tìm mọt bài gần nhất với trường hợp của mình rồi cho biết tại sao nó khong áp dụng được.
Sẽ có người giúp bạn giải quyết các chỗ ấy.

 

[hieuhus]

Bài toán này không có gì xa lạ hay mới mẻ cả. Nhiều người gặp rồi cho nên bài giải ở đây có cả đống.
Bạn tìm mọt bài gần nhất với trường hợp của mình rồi cho biết tại sao nó khong áp dụng được.
Sẽ có người giúp bạn giải quyết các chỗ ấy.

Cảm ơn bạn đã góp ý.
Mình tìm trên diễn đàn thì có bài này, cũng tương tự với bài của mình

Xin chỉ giúp VBA hoặc công thức chèn dòng có điều kiện

Xin các bác giúp em với ạ. Chèn dòng theo điều kiện ở cột A trong file bằng VBA hoặc bằng công thức đều được ạ. Xin đa tạ.

www.giaiphapexcel.com

Sub Chendong()
Dim ws As Worksheet
Dim rg As Range
Dim lr, i, j As Long
Dim c As Variant

Set ws = ActiveSheet
lr = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set rg = ws.Range("A1:A" & lr)

For i = lr To 2 Step -1
c = rg.Cells(i).Value
If IsNumeric(c) And c > 0 Then
For j = 1 To c
rg.Cells(i).EntireRow.Insert xlShiftDown
Next j
End If
Next i
MsgBox "OK! Xong!"
End Sub

Nhưng trước khi chạy code thì mình phải làm thêm 1 bước trung gian nữa: Ở cột A phải nhập số dòng muốn thêm vào cho các Section. Bước này thì mình dùng hàm Index và Match nên đã làm được rồi.

Giờ mình muốn tối ưu lại code để có thể sử dụng được luôn, không phải làm thêm bước trung gian ở trên nữa.

 

[SA_DQ]

Mình tìm trên diễn đàn thì có bài này, cũng tương tự với bài của mình . . . . . .
Giờ mình muốn tối ưu lại code để có thể sử dụng được luôn, không phải làm thêm bước trung gian ở trên nữa.

Mình phát thảo cách này, nếu bạn có thời gian thì thử đưa vô thành cách . . . khác
(1) Bước chuẩn bị:
→ Tìm dòng cuối của DL (dữ liệu) Rws & tổng các dòng cần thêm Dg (cột 'I")
→ Khai báo các biến đếm & 1 mảng gồm số cột bằng với số cột cuả DL & số dòng là Rws + Dg
→ Khai báo 1 tham biến Double để chứa trị Section, 1 biến vùng Rng là các ô có DL của cột 'I'
(2)
→ Thiết lập vòng lặp từ dòng 2 cho tới dòng Rws
Trong khi duyệt thì ghi trị của cột 'C' vô tham biến Section
Tăng biến đếm dòng của mảng lên 1 đơn vị & ghi DL dòng đang duyệt vô biến mảng
Khi duyệt nếu dòng tiếp theo có trị khác với Section thì tăng biến đếm ô Rng thêm 1 (W=W+1)
Lấy trị trong trong Rng(W) để tăng tương ứng chỉ số dòng trong mảng
. . . . .
(3) Ghi kết quả từ mảng lên trang tính

Chúc bạn chủ bài đăng thành công!

 

[bebo021999]

Code dưới đây 1 phát ăn ngay, không cần trung gian.
Vùng H:K chỉ để kiểm tra, không liên quan đến code.
Vì mình không rõ sau khi insert thêm dòng, thì cột A bạn muốn để trống hay điền mã "section" vào.
Do đó mình đã giả định là có điền mã vào.
Nếu không thì bạn delete dòng đó đi (các dòng có chú thích "bo dong nay di, neu ban muon cot A trong")

Option Explicit
Sub insertDong()
Dim lr&, i&, j&, k&, c&, rng, res(1 To 100000, 1 To 3)
Const sodong = 54 ' xac dinh so dong tieu chuan tai day!
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:C" & lr).Value
c = sodong
For i = 2 To UBound(rng)
    If rng(i, 1) = rng(i - 1, 1) Then
        k = k + 1: c = c - 1
        res(k, 1) = rng(i, 1): res(k, 2) = rng(i, 2): res(k, 3) = rng(i, 3)
    Else
        If c > 0 Then
            For j = 1 To c
                k = k + 1
                res(k, 1) = rng(i - 1, 1) ' bo dong nay di, neu ban muon cot A trong
            Next
        End If
        c = sodong
    End If
Next

' bo cac dong nay di, neu ban muon cot A trong
'-------------------------------------------------
If c > 0 Then
    For j = 1 To c
        k = k + 1
        res(k, 1) = rng(UBound(rng), 1) ' bo dong nay di, neu ban muon cot A trong
    Next
End If
'-------------------------------------------------

Range("A2:C100000").ClearContents
Range("A2").Resize(k, 3).Value = res
End Sub

Bài đã được tự động gộp: 17/7/23

 

[ptm0412]

Một cách khác: Bỏ cũ làm mới
- Lấy 1 mảng từ dữ liệu ban đầu Source
- Lấy mảng số dòng yêu cầu vào 1 Dict: key = section, item = số dòng cần thêm = 54 - số dòng đã có
- Tạo mảng kết quả có số dòng = 54 * Dict.Count (tạo chi 1 triệu dòng)
- Duyệt mảng Source, gán từng dòng source vào kết quả.
- đặt điều kiện sao cho khi section thay đổi thì thêm dòng trắng trong mảng kết quả (có section hay không tùy ý), số dòng trắng = item của Dict tương ứng
- tiếp tục duyệt mảng source tại dòng tạm ngưng
- cu6i1 cùng ghi kết quả đè lên dữ liệu nguồn hoặc tại cột mới tùy thích

 

[hieuhus]

Code dưới đây 1 phát ăn ngay, không cần trung gian.
Vùng H:K chỉ để kiểm tra, không liên quan đến code.
Vì mình không rõ sau khi insert thêm dòng, thì cột A bạn muốn để trống hay điền mã "section" vào.
Do đó mình đã giả định là có điền mã vào.
Nếu không thì bạn delete dòng đó đi (các dòng có chú thích "bo dong nay di, neu ban muon cot A trong")

Option Explicit
Sub insertDong()
Dim lr&, i&, j&, k&, c&, rng, res(1 To 100000, 1 To 3)
Const sodong = 54 ' xac dinh so dong tieu chuan tai day!
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:C" & lr).Value
c = sodong
For i = 2 To UBound(rng)
    If rng(i, 1) = rng(i - 1, 1) Then
        k = k + 1: c = c - 1
        res(k, 1) = rng(i, 1): res(k, 2) = rng(i, 2): res(k, 3) = rng(i, 3)
    Else
        If c > 0 Then
            For j = 1 To c
                k = k + 1
                res(k, 1) = rng(i - 1, 1) ' bo dong nay di, neu ban muon cot A trong
            Next
        End If
        c = sodong
    End If
Next

' bo cac dong nay di, neu ban muon cot A trong
'-------------------------------------------------
If c > 0 Then
    For j = 1 To c
        k = k + 1
        res(k, 1) = rng(UBound(rng), 1) ' bo dong nay di, neu ban muon cot A trong
    Next
End If
'-------------------------------------------------

Range("A2:C100000").ClearContents
Range("A2").Resize(k, 3).Value = res
End Sub

Bài đã được tự động gộp: 17/7/23

Code này đúng yêu cầu bài toán của mình rồi. Cảm ơn bạn đã giúp đỡ!

 

[VetMini]

Một cách khác: Bỏ cũ làm mới
...

Loại bài không đủ chi tiết lô gic này tôi không buonf làm.
Ít nhất thớt phải cho biết nếu số dòng NHỎ HƠN số dòng hiện có của nhóm thì sao?

Khi tôi bảo thớt chịu khó tìm là muốn nhắc nhở. Nếu thật sự chịu khó tìm thì đã biết có mấy bài nhắc đến việc này tồi.

 

[ptm0412]

Ít nhất thớt phải cho biết nếu số dòng NHỎ HƠN số dòng hiện có của nhóm thì sao?

Anh nói đúng. Tuy nhiên với dữ liệu này thì mỗi dòng gốc hiện tại đang có dữ liệu, chẳng lẽ dư thì xóa bỏ. Nên có lẽ không có chuyện nhỏ hơn số dòng hiện có.

 

[hieuhus]

Code dưới đây 1 phát ăn ngay, không cần trung gian.
Vùng H:K chỉ để kiểm tra, không liên quan đến code.
Vì mình không rõ sau khi insert thêm dòng, thì cột A bạn muốn để trống hay điền mã "section" vào.
Do đó mình đã giả định là có điền mã vào.
Nếu không thì bạn delete dòng đó đi (các dòng có chú thích "bo dong nay di, neu ban muon cot A trong")

Option Explicit
Sub insertDong()
Dim lr&, i&, j&, k&, c&, rng, res(1 To 100000, 1 To 3)
Const sodong = 54 ' xac dinh so dong tieu chuan tai day!
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:C" & lr).Value
c = sodong
For i = 2 To UBound(rng)
    If rng(i, 1) = rng(i - 1, 1) Then
        k = k + 1: c = c - 1
        res(k, 1) = rng(i, 1): res(k, 2) = rng(i, 2): res(k, 3) = rng(i, 3)
    Else
        If c > 0 Then
            For j = 1 To c
                k = k + 1
                res(k, 1) = rng(i - 1, 1) ' bo dong nay di, neu ban muon cot A trong
            Next
        End If
        c = sodong
    End If
Next

' bo cac dong nay di, neu ban muon cot A trong
'-------------------------------------------------
If c > 0 Then
    For j = 1 To c
        k = k + 1
        res(k, 1) = rng(UBound(rng), 1) ' bo dong nay di, neu ban muon cot A trong
    Next
End If
'-------------------------------------------------

Range("A2:C100000").ClearContents
Range("A2").Resize(k, 3).Value = res
End Sub

Bài đã được tự động gộp: 17/7/23

Code dưới đây 1 phát ăn ngay, không cần trung gian.
Vùng H:K chỉ để kiểm tra, không liên quan đến code.
Vì mình không rõ sau khi insert thêm dòng, thì cột A bạn muốn để trống hay điền mã "section" vào.
Do đó mình đã giả định là có điền mã vào.
Nếu không thì bạn delete dòng đó đi (các dòng có chú thích "bo dong nay di, neu ban muon cot A trong")

Option Explicit
Sub insertDong()
Dim lr&, i&, j&, k&, c&, rng, res(1 To 100000, 1 To 3)
Const sodong = 54 ' xac dinh so dong tieu chuan tai day!
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:C" & lr).Value
c = sodong
For i = 2 To UBound(rng)
    If rng(i, 1) = rng(i - 1, 1) Then
        k = k + 1: c = c - 1
        res(k, 1) = rng(i, 1): res(k, 2) = rng(i, 2): res(k, 3) = rng(i, 3)
    Else
        If c > 0 Then
            For j = 1 To c
                k = k + 1
                res(k, 1) = rng(i - 1, 1) ' bo dong nay di, neu ban muon cot A trong
            Next
        End If
        c = sodong
    End If
Next

' bo cac dong nay di, neu ban muon cot A trong
'-------------------------------------------------
If c > 0 Then
    For j = 1 To c
        k = k + 1
        res(k, 1) = rng(UBound(rng), 1) ' bo dong nay di, neu ban muon cot A trong
    Next
End If
'-------------------------------------------------

Range("A2:C100000").ClearContents
Range("A2").Resize(k, 3).Value = res
End Sub

Bài đã được tự động gộp: 17/7/23

Khi chạy thì dòng đã chèn đủ theo số lượng nhưng dữ liệu ở dòng đầu tiên của mỗi "Section" đã bị xóa đi. Bạn sửa giúp mình được không

 

[bebo021999]

Thử lại nhé bạn:

Option Explicit
Sub insertDong()
Dim lr&, i&, j&, k&, rng, res(1 To 100000, 1 To 3)
Dim dic As Object, key
Set dic = CreateObject("Scripting.Dictionary")
Const sodong = 54 ' xac dinh so dong tieu chuan tai day!
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:C" & lr).Value
For i = 1 To UBound(rng)
    If Not dic.exists(rng(i, 1)) Then
        dic.Add rng(i, 1), 1
    Else
        dic(rng(i, 1)) = dic(rng(i, 1)) + 1
    End If
Next
For Each key In dic.keys
    For i = 1 To UBound(rng)
        If key = rng(i, 1) Then
            k = k + 1: res(k, 1) = rng(i, 1): res(k, 2) = rng(i, 2): res(k, 3) = rng(i, 3)
        End If
    Next
    If dic(key) < sodong Then
        For j = dic(key) + 1 To sodong
            k = k + 1: res(k, 1) = key
        Next
    End If
Next
Range("A2:C100000").ClearContents
Range("A2").Resize(k, 3).Value = res
End Sub

 

[SA_DQ]

Sub ThemDong()
 Dim Rws As Long, J As Long, W As Integer, SecTion As Double, Dm As Integer
 Dim Rng As Range
  
 Rws = [C2].CurrentRegion.Rows.Count
 Set Rng = [I2].Resize([I2].CurrentRegion.Rows.Count)
 J = Application.WorksheetFunction.Sum(Rng)
 ReDim Arr(1 To Rws + 2 * J, 1 To 4) As Variant
 SecTion = [C2].Value
 For J = 2 To Rws
    If Cells(J, "C").Value <> SecTion Then
        Dm = Dm + 1
        W = W + Rng(Dm).Value   'Sô Dòng Cân Thêm Mói Cho 1 SecTion '
        If IsNumeric(Cells(J, "C").Value) Then
            SecTion = Cells(J, "C").Value
        Else
            GoTo GPE
        End If
    End If
    W = W + 1:                          Arr(W, 1) = W
    Arr(W, 2) = SecTion:                Arr(W, 3) = Cells(J, "D").Value
    Arr(W, 4) = Cells(J, "E").Value
 Next J
GPE:
 [P2].Resize(W, 4).Value = Arr()
End Sub

 

[hieuhus]

Thử lại nhé bạn:

Option Explicit
Sub insertDong()
Dim lr&, i&, j&, k&, rng, res(1 To 100000, 1 To 3)
Dim dic As Object, key
Set dic = CreateObject("Scripting.Dictionary")
Const sodong = 54 ' xac dinh so dong tieu chuan tai day!
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:C" & lr).Value
For i = 1 To UBound(rng)
    If Not dic.exists(rng(i, 1)) Then
        dic.Add rng(i, 1), 1
    Else
        dic(rng(i, 1)) = dic(rng(i, 1)) + 1
    End If
Next
For Each key In dic.keys
    For i = 1 To UBound(rng)
        If key = rng(i, 1) Then
            k = k + 1: res(k, 1) = rng(i, 1): res(k, 2) = rng(i, 2): res(k, 3) = rng(i, 3)
        End If
    Next
    If dic(key) < sodong Then
        For j = dic(key) + 1 To sodong
            k = k + 1: res(k, 1) = key
        Next
    End If
Next
Range("A2:C100000").ClearContents
Range("A2").Resize(k, 3).Value = res
End Sub

Cảm ơn bạn đã giúp đỡ.

Bài đã được tự động gộp: 18/7/23

Sub ThemDong()
 Dim Rws As Long, J As Long, W As Integer, SecTion As Double, Dm As Integer
 Dim Rng As Range
 
 Rws = [C2].CurrentRegion.Rows.Count
 Set Rng = [I2].Resize([I2].CurrentRegion.Rows.Count)
 J = Application.WorksheetFunction.Sum(Rng)
 ReDim Arr(1 To Rws + 2 * J, 1 To 4) As Variant
 SecTion = [C2].Value
 For J = 2 To Rws
    If Cells(J, "C").Value <> SecTion Then
        Dm = Dm + 1
        W = W + Rng(Dm).Value   'Sô Dòng Cân Thêm Mói Cho 1 SecTion '
        If IsNumeric(Cells(J, "C").Value) Then
            SecTion = Cells(J, "C").Value
        Else
            GoTo GPE
        End If
    End If
    W = W + 1:                          Arr(W, 1) = W
    Arr(W, 2) = SecTion:                Arr(W, 3) = Cells(J, "D").Value
    Arr(W, 4) = Cells(J, "E").Value
 Next J
GPE:
 [P2].Resize(W, 4).Value = Arr()
End Sub

Cảm ơn bạn đã giúp đỡ.

 

[ptm0412]

Những code đã viết bên trên không biết đã lường tới việc thứ tự bảng 2 không giống thứ tự bảng 1 chưa? Bảng 1 thì chắc chắn phải được sort rồi, không nói.

 

[bebo021999]

Những code đã viết bên trên không biết đã lường tới việc thứ tự bảng 2 không giống thứ tự bảng 1 chưa? Bảng 1 thì chắc chắn phải được sort rồi, không nói.

Bảng 2 chỉ là mô phỏng. Thực tế là chỉ có 1 bảng 1, và copy/paste tại chỗ thôi.
Code em làm tại bài 11 dùng dic, nên bảng 1 có thể sort hay chưa sort không quan trọng. Nó list lại theo thứ tự xuất hiện, bảo đảm số dòng của từng item >=54