Giúp mình viết code chèn dòng có điều kiện với các pro (2 người xem)

[myluck]

Hiện tại mình có code sau để chèn dòng có điều kiện
- Các ô gần nhau có giá trị khác nhau mới chèn. Nhưng code này chạy chậm quá có Pro nào giúp nó chạy nhanh hơn không????
- Nếu có code nào chèn dòng có điều kiện thì giúp mình với
Option Explicit
Public Sub Insert_Row()
On Error GoTo thoat
Dim rngData As Range
Dim rngThaydoi As Range
Dim i As Integer, j As Integer
Set rngData = Selection
i = 2
For j = 2 To rngData.Rows.Count * 2
If rngData.Cells(i, 1) <> rngData.Cells(i - 1, 1) And Not IsEmpty(rngData.Cells(i, 1)) Then
rngData.Cells(i, 1).Select
Selection.EntireRow.Insert
i = i + 2
Else
i = i + 1
End If

Next j
rngData.Cells(1, 1).Select
thoat:
End Sub

 

[myluck]

Có ai ko giúp mình với

 

[huuthang_bd]

Đưa code mà không đưa dữ liệu thì cũng như không. Ai rảnh đâu mà ngồi đọc code rồi suy ra dữ liệu của bạn.

 

[myluck]

Xin lỗi bác! Cứ tưởng ai đang làm công tác của mình!
Mình gửi file lên
Cái này chọn vùng rồi nó chèn! Nhưng vùng của mình rộng quá nên nó chạy chậm
Mong các pro giúp nó nhanh hơn

 

[VetMini]

Chèn dòng hay xoá dòng thì luôn luôn làm từ dưới lên trên.
Làm trên xuống dưới vừa chậm vừa dễ sai.

 

[SA_DQ]

Dữ liệu trang tính không chứa công thức nha!

Option Explicit
Sub InSertBlankRows()
 Dim Rng As Range, Arr()
 Dim Rws&, Col%, J&, Dg&, Cot%, Tmr#
 
 Sheet1.Select:             Tmr = Timer()
 Set Rng = Sheet1.UsedRange
 Rws = Rng.Rows.Count + 9
 Col = Rng.Columns.Count
 ReDim dArr(1 To 2 * Rws, 1 To Col)
 Arr() = Rng.Value2
 On Error Resume Next
 For J = 1 To Rws
    Dg = Dg + 1
    For Cot = 1 To Col
        dArr(Dg, Cot) = Arr(J, Cot)
    Next Cot
    If Arr(J, 1) <> Arr(J + 1, 1) Then Dg = Dg + 1
 Next J
 With Cells(1, Col + 2)
    .Resize(Dg, Col).Value = dArr()
    .Value = Timer() - Tmr
 End With
End Sub

 

[myluck]

Option Explicit
Sub InSertBlankRows()
 Dim Rng As Range, Arr()
 Dim Rws&, Col%, J&, Dg&, Cot%, Tmr#
 
 Sheet1.Select:             Tmr = Timer()
 Set Rng = Sheet1.UsedRange
 Rws = Rng.Rows.Count + 9
 Col = Rng.Columns.Count
 ReDim dArr(1 To 2 * Rws, 1 To Col)
 Arr() = Rng.Value2
 On Error Resume Next
 For J = 1 To Rws
    Dg = Dg + 1
    For Cot = 1 To Col
        dArr(Dg, Cot) = Arr(J, Cot)
    Next Cot
    If Arr(J, 1) <> Arr(J + 1, 1) Then Dg = Dg + 1
 Next J
 With Cells(1, Col + 2)
    .Resize(Dg, Col).Value = dArr()
    .Value = Timer() - Tmr
 End With
End Sub

Sao mình ko chạy được nhỉ?? Bạn đã thử chưa xem lại hộ mình với!

 

[SA_DQ]

[Thongbao]Sao mình ko chạy được nhỉ?? Bạn đã thử chưa xem lại hộ mình với![/Thongbao]

Hiện tại macro đang chép sang vùng mới cách vùng dữ liệu cũ 1 cột trống.


(*) Nếu vùng dữ liệu đang xài lớn hơn nữa số cột trang tính sẽ gặp trỡ ngại

(*) Nếu các dòng đầu trang tính là trống thì thử bỏ đi.

(*) Có thể dùng hộp thoại MSGBox() để hỏi macro xem nó chạy tới đâu & đang có gì trong các biến,. . . .

 

[VetMini]

Giao thiệp mà dùng tiếng Tây gọi nhau tôi ngại lắm. Bạn sửa những chỗ tiếng Tây rồi nói chuyện tiếp.
Bằng không thì cứ bình tĩnh chờ sẽ có người khác giúp, "không mợ chợ cũng đông" mà.

 

[huuthang_bd]

Xin lỗi bác! Cứ tưởng ai đang làm công tác của mình!
Mình gửi file lên
Cái này chọn vùng rồi nó chèn! Nhưng vùng của mình rộng quá nên nó chạy chậm
Mong các pro giúp nó nhanh hơn

Bạn thử vầy thử xem

Public Sub Insert_Row()
On Error GoTo Thoat
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim RngData As Range, ArrData, i As Long
If Selection.Areas(1).Rows.Count = 1 Then GoTo Thoat
Set RngData = Selection.Areas(1)
ArrData = RngData.Resize(, 1).Value
For i = UBound(ArrData, 1) To 2 Step -1
    If ArrData(i, 1) <> "" Then
        If ArrData(i, 1) <> ArrData(i - 1, 1) Then RngData(i, 1).EntireRow.Insert xlDown
    End If
Next
RngData.Select
Thoat:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[yellowflash89]

Hiện tại mình có code sau để chèn dòng có điều kiện
- Các ô gần nhau có giá trị khác nhau mới chèn. Nhưng code này chạy chậm quá có Pro nào giúp nó chạy nhanh hơn không????
- Nếu có code nào chèn dòng có điều kiện thì giúp mình với
Option Explicit
Public Sub Insert_Row()
On Error GoTo thoat
Dim rngData As Range
Dim rngThaydoi As Range
Dim i As Integer, j As Integer
Set rngData = Selection
i = 2
For j = 2 To rngData.Rows.Count * 2
If rngData.Cells(i, 1) <> rngData.Cells(i - 1, 1) And Not IsEmpty(rngData.Cells(i, 1)) Then
rngData.Cells(i, 1).Select
Selection.EntireRow.Insert
i = i + 2
Else
i = i + 1
End If

Next j
rngData.Cells(1, 1).Select
thoat:
End Sub

Với đoạn code trên, nhờ các bác giúp em tô màu các hàng vừa được chèn vào được không ? Em cám ơn.

 

[SA_DQ]

Bạn tham khảo macro sau:

Public Sub Insert_Row()
 On Error GoTo thoat
 Dim rngData As Range, rngThaydoi As Range
 Dim i As Integer, j As Integer
 Set rngData = Selection
 i = 2:         Randomize
 For j = 2 To rngData.Rows.Count * 2
    If rngData.Cells(i, "R") <> rngData.Cells(i - 1, "R") And Not IsEmpty(rngData.Cells(i, "R")) Then
        rngData.Cells(i, "R").Select
        Selection.EntireRow.Insert
        rngData.Cells(i, "A").Resize(, 20).Interior.ColorIndex = 34 + 9 * Rnd() \ 1
        i = i + 2
    Else
        i = i + 1
    End If
Next j
rngData.Cells(1, 1).Select
thoat:
End Sub