Cải thiện code vba thêm dòng mới sau mỗi 10 dòng

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
Ngân Nguyễn 9x

Ngân Nguyễn 9x

Thành viên mới
Tham gia
16/3/23
Bài viết
13
Được thích
10
Dạ em có đoạn code sau, cứ sau mỗi 10 dòng em lại chèn thêm 1 dòng trống. Hiện code này đang đúng song vẫn chạy khá chậm nếu số lượng dòng lớn, các anh chị giúp em tối ưu với ạ, e cảm ơn nhiều nhiều ạ.

Sub AddRowsEvery10()
Dim a, b As Double
Dim i As Integer
Dim rowCount As Integer

rowCount = Sheet1.UsedRange.Rows.Count

a = Timer
Application.DisplayAlerts = False
Application.ScreenUpdating = False

For i = 10 To rowCount Step 10
Rows(i + 1).Insert
Next i

b = Timer
Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox Round(b - a, 2)
End Sub
 

File đính kèm

  • thêm dòng.xlsm
    31.8 KB · Đọc: 6
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn đang có 2 000 dòng có DL (dữ liệu); Được cái là DL là số tăng dần rất chi là đều
Chương trình của bạn đã tạo vòng lặp 200 lần để thêm 200 dòng trắng;
[Điều kiện là trang tính này sẽ còn các cột DL khác]
Mình nghỉ 1 cách khác: Cũng xài 1 vòng lặp 206 nhưng thay vì thêm dòng ta cải biên:
Bắt đầu từ dòng cuối cùng có DL +1 trở đi ta quýnh các số 10, 20, . . . . 200
Tiến hành xếp theo chiều tăng dần của cột này

Bạn thử xem cách làm nào nhanh hơn đi nha.
 
Upvote 0
SA_DQ đã viết:
Bạn đang có 2 000 dòng có DL (dữ liệu); Được cái là DL là số tăng dần rất chi là đều
Chương trình của bạn đã tạo vòng lặp 200 lần để thêm 200 dòng trắng;
[Điều kiện là trang tính này sẽ còn các cột DL khác]
Mình nghỉ 1 cách khác: Cũng xài 1 vòng lặp 206 nhưng thay vì thêm dòng ta cải biên:
Bắt đầu từ dòng cuối cùng có DL +1 trở đi ta quýnh các số 10, 20, . . . . 200
Tiến hành xếp theo chiều tăng dần của cột này

Bạn thử xem cách làm nào nhanh hơn đi nha.
Nhấp chuột vào đây để mở rộng...
dạ e cảm ơn a nhiều ạ
 
Upvote 0
Đã là dân code thì nên tập viết từ cho rõ. Quen viết tắt chỉ có hai về sau.

Code chỉ có thể cải thiện được một chút như sau:
(chú ý: insert thì phphaitwf dưới lên tren chứ từ trên xuống thì số dòng sai hết.)

Sub AddRowsEvery10()
Dim t as Double
Dim i As Integer
Dim SvAlrt, SvScrn, SvCalc
SvAlrt = Application.DisplayAlerts
SvScrn = Application.ScreenUpdating
SvCalc = Application.Calculation
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
t = Timer
For i = (Sheet1.UsedRange.Rows.Count \ 10) + 1 To 11 Step -10
Rows(i).Insert
Next i
t = Timer - t
Application.ScreenUpdating = SvScrn
Application.DisplayAlerts = SvAlrt
Application.Calculation = SvCalc
MsgBox Round(t, 2)
End Sub

Cách khá hơn một chutsn là Union các chỗ cần insert lại và llàm một lượt.

Tuye nhiên, Insert dòng luôn luôn chậm.
Vì vậy chỉ có thể thay đổi giải thuật chứ khó thay đổi code.

Giải thuật khác (làm tay cũng được mà code cũng được):
1. Tạo một cột phụ
2. Trong cột phụ, đánh số từ 1 đến n
3. Sau dòng cuỗi, tiếp tục đánh sô 10.1, 20.1, 30.1,...
4. Sort theo cột phụ.
5. Xóa cột phụ
6. Hết
 
Upvote 0
VetMini đã viết:
Đã là dân code thì nên tập viết từ cho rõ. Quen viết tắt chỉ có hai về sau.

Code chỉ có thể cải thiện được một chút như sau:
(chú ý: insert thì phphaitwf dưới lên tren chứ từ trên xuống thì số dòng sai hết.)

Sub AddRowsEvery10()
Dim t as Double
Dim i As Integer
Dim SvAlrt, SvScrn, SvCalc
SvAlrt = Application.DisplayAlerts
SvScrn = Application.ScreenUpdating
SvCalc = Application.Calculation
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
t = Timer
For i = (Sheet1.UsedRange.Rows.Count \ 10) + 1 To 11 Step -10
Rows(i).Insert
Next i
t = Timer - t
Application.ScreenUpdating = SvScrn
Application.DisplayAlerts = SvAlrt
Application.Calculation = SvCalc
MsgBox Round(t, 2)
End Sub

Cách khá hơn một chutsn là Union các chỗ cần insert lại và llàm một lượt.

Tuye nhiên, Insert dòng luôn luôn chậm.
Vì vậy chỉ có thể thay đổi giải thuật chứ khó thay đổi code.

Giải thuật khác (làm tay cũng được mà code cũng được):
1. Tạo một cột phụ
2. Trong cột phụ, đánh số từ 1 đến n
3. Sau dòng cuỗi, tiếp tục đánh sô 10.1, 20.1, 30.1,...
4. Sort theo cột phụ.
5. Xóa cột phụ
6. Hết
Nhấp chuột vào đây để mở rộng...
Dạ e cảm ơn a nhiều ạ, a chỉ rất chi tiết
 
Upvote 0
Upvote 0
VetMini đã viết:
Đã là dân code thì nên tập viết từ cho rõ. Quen viết tắt chỉ có hai về sau.

Code chỉ có thể cải thiện được một chút như sau:
(chú ý: insert thì phphaitwf dưới lên tren chứ từ trên xuống thì số dòng sai hết.)

Sub AddRowsEvery10()
Dim t as Double
Dim i As Integer
Dim SvAlrt, SvScrn, SvCalc
SvAlrt = Application.DisplayAlerts
SvScrn = Application.ScreenUpdating
SvCalc = Application.Calculation
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
t = Timer
For i = (Sheet1.UsedRange.Rows.Count \ 10) + 1 To 11 Step -10
Rows(i).Insert
Next i
t = Timer - t
Application.ScreenUpdating = SvScrn
Application.DisplayAlerts = SvAlrt
Application.Calculation = SvCalc
MsgBox Round(t, 2)
End Sub

Cách khá hơn một chutsn là Union các chỗ cần insert lại và llàm một lượt.

Tuye nhiên, Insert dòng luôn luôn chậm.
Vì vậy chỉ có thể thay đổi giải thuật chứ khó thay đổi code.

Giải thuật khác (làm tay cũng được mà code cũng được):
1. Tạo một cột phụ
2. Trong cột phụ, đánh số từ 1 đến n
3. Sau dòng cuỗi, tiếp tục đánh sô 10.1, 20.1, 30.1,...
4. Sort theo cột phụ.
5. Xóa cột phụ
6. Hết
Nhấp chuột vào đây để mở rộng...
Viết cũng sai chính tả
 
Upvote 0
Ngân Nguyễn 9x đã viết:
Dạ em có đoạn code sau, cứ sau mỗi 10 dòng em lại chèn thêm 1 dòng trống. Hiện code này đang đúng song vẫn chạy khá chậm nếu số lượng dòng lớn, các anh chị giúp em tối ưu với ạ, e cảm ơn nhiều nhiều ạ.

Sub AddRowsEvery10()
Dim a, b As Double
Dim i As Integer
Dim rowCount As Integer

rowCount = Sheet1.UsedRange.Rows.Count

a = Timer
Application.DisplayAlerts = False
Application.ScreenUpdating = False

For i = 10 To rowCount Step 10
Rows(i + 1).Insert
Next i

b = Timer
Application.DisplayAlerts = True
Application.ScreenUpdating = True

MsgBox Round(b - a, 2)
End Sub
Nhấp chuột vào đây để mở rộng...
Sửa lại code chút xíu:
Rich (BB code): 
Sub AddRowsEvery10()
    Dim a, b As Double
    Dim i As Integer
    Dim rowCount As Integer, Rng As Range
    
    rowCount = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    
    a = Timer
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    For i = 10 To rowCount Step 10
        If Rng Is Nothing Then
            Set Rng = Rows(i + 1)
        Else
            Set Rng = Union(Rng, Rows(i + 1))
        End If
    Next i
    Rng.Insert
    b = Timer
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox Round(b - a, 2)
End Sub
 
Upvote 0
VetMini đã viết:
Thà chửi tôi chứ đừng dùng cái loại ngôn ngữ viết tắt này với tôi.
Người chung quanh, bạn bè tôi mà biết tôi nói chuyện với dân viết tắt chúng sẽ khi dễ tôi.
Nhấp chuột vào đây để mở rộng...
Bác khó tính đi đâu cũng khó tính vậy à. Viết tắt cho nó nhanh tí thôi mà.
Nhớ mấy năm trước đâu có khó vậy đâu ta, tầm 2019-20 chớ mấy !
 
Upvote 0
Tối quá, tình cờ buồn buồn vọc chơi, cho 20.000 dòng, chạy code ở bài #8, ngủ quên, sáng nay mở mắt kiểm tra thấy code vẫn còn chạy.
Chạy thử code dưới đây thấy khá khẩm hơn 1 chút.
PHP: 
Sub test()
Dim lr As Double, i As Double, t
t = Timer
lr = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
With Range("ZZ2:ZZ" & lr)
    .Formula = "=1/MOD(ROW()-1,10)"
    .Value = .Value
    .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Insert
End With
Columns("ZZ").ClearContents
[A1].Select
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub
 
Upvote 0

Ngân Nguyễn 9x​

Sử dụng Hàm Union gộp Range, để tiết kiệm tài nguyên bạn nhé
Tốt nhất nên khai báo ô bắt đầu.
JavaScript: 
Sub AddRowsEvery10()
  Dim a, i%, rowCount&, rg As Range, cell As Range
  Set cell = Sheet1.Range("A1")
  rowCount = cell.parent.UsedRange.Rows.count - cell.row + 1
  a = Timer
  With Application: .DisplayAlerts = False: .ScreenUpdating = False: .EnableEvents = False
    '------------------------------------
    For i = 11 To rowCount Step 10
      If Not rg Is Nothing Then Set rg = Union(rg, cell(i, 1)) Else Set rg = cell(i, 1)
    Next i
    If Not rg Is Nothing Then
      rg.EntireRow.Insert: MsgBox "Insert complete: " & Round(Timer - a, 2)
    Else
      MsgBox "Rows Empty!"
    End If
    '------------------------------------
    .DisplayAlerts = True: .ScreenUpdating = True: .EnableEvents = True
  End With
 
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Maika8008 đã viết:
Set Rng = Union(Rng, Rows(i + 1))
Nhấp chuột vào đây để mở rộng...

Union đúng là chỉ kha khá hơn tí tẹo mà thôi anh. Và nó chỉ khá hơn khi làm việc với số lượng ít, nhiều là sập toàn thiên nhiên, bò tới vài mùa quýt chín =]]]
(như bài #10 dẫn chứng).

Bài này chỉ có cách dùng cột phụ và sort (như bài #4 đã nêu), hoặc dùng Array.

Maika8008 đã viết:
If Rng Is Nothing Then
Nhấp chuột vào đây để mở rộng...
Nhân tiện vụ này, hóa ra sau bao nhiêu năm vẫn chưa thấy có ai tìm ra kỹ thuật bỏ qua cái If này. Híc.
 
Upvote 0
bebo021999 đã viết:
Tối quá, tình cờ buồn buồn vọc chơi, cho 20.000 dòng, chạy code ở bài #8, ngủ quên, sáng nay mở mắt kiểm tra thấy code vẫn còn chạy.
Chạy thử code dưới đây thấy khá khẩm hơn 1 chút.
PHP: 
Sub test()
Dim lr As Double, i As Double, t
t = Timer
lr = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
With Range("ZZ2:ZZ" & lr)
    .Formula = "=1/MOD(ROW()-1,10)"
    .Value = .Value
    .SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Insert
End With
Columns("ZZ").ClearContents
[A1].Select
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub
Nhấp chuột vào đây để mở rộng...
Code bài #8 trên máy tôi chạy 20.000 dòng mất chừng 35 giây. Tuy nhiên với 40.000 dòng thì lâu quá, tôi chưa chờ thủ mất bao lâu.
Bài đã được tự động gộp:

befaint đã viết:
Union đúng là chỉ kha khá hơn tí tẹo mà thôi anh. Và nó chỉ khá hơn khi làm việc với số lượng ít, nhiều là sập toàn thiên nhiên, bò tới vài mùa quýt chín =]]]
(như bài #10 dẫn chứng).

Bài này chỉ có cách dùng cột phụ và sort (như bài #4 đã nêu), hoặc dùng Array.


Nhân tiện vụ này, hóa ra sau bao nhiêu năm vẫn chưa thấy có ai tìm ra kỹ thuật bỏ qua cái If này. Híc.
Nhấp chuột vào đây để mở rộng...
Dùng Array thì nhanh nhưng sẽ phá hết công thức (nếu có)
Còn vụ if kia quả thực là chưa có gì thay thế cho gọn hết hả bạn?
 
Upvote 0
hoangexcell đã viết:
Bác khó tính đi đâu cũng khó tính vậy à. Viết tắt cho nó nhanh tí thôi mà.
Nhớ mấy năm trước đâu có khó vậy đâu ta, tầm 2019-20 chớ mấy !
Nhấp chuột vào đây để mở rộng...
Nhớ tầm bậy rồi tuyên bố nhảm!!!
Ở đây ai cũng biết tôi luôn giữ vững lạp trường. Chỉ mình bạn cố tình xuyên tạc.

Dân quen viết tắt thì cũng có thói chủ quan và cẩu thả.
Ở nài #4 tôi có nói rõ là dân lập trình không nên theo thói viết tắt.
Ở bài #3, thớt trả lời bằng câu với mấy từ viết tắt:
1. Thớt cố tình bẽ mặt tôi, hoăc
2. Không cố tình, chỉ do tính chủ quan và cẩu thả
 
Lần chỉnh sửa cuối:
Upvote 0
VetMini đã viết:
Nhớ tầm bậy rồi tuyên bố nhảm!!!
Ở đây ai cũng biết tôi luôn giữ vững lạp trường. Chỉ mình bạn cố tình xuyên tạc.

Dân quen viết tắt thì cũng có thói chủ quan và cẩu thả.
Ở nài #4 tôi có nói rõ là dân lập trình không nên theo thói viết tắt.
Ở bài #3, thớt trả lời bằng câu với mấy từ viết tắt:
1. Thớt cố tình bẽ mặt tôi, hoăc
2. Không cố tình, chỉ do tính chủ quan và cẩu thả
Nhấp chuột vào đây để mở rộng...
1679457830083.png

Ô thế mình đang hiểu nhầm à. Theo bài tới đoạn như hình thì nghĩ là bắt bẽ chữ viết tắt: a thay cho Anh!
Nếu không phải thế thì thôi nhé. Xí xóa nhé!
 
Upvote 0
befaint đã viết:
Union đúng là chỉ kha khá hơn tí tẹo mà thôi anh. Và nó chỉ khá hơn khi làm việc với số lượng ít, nhiều là sập toàn thiên nhiên, bò tới vài mùa quýt chín =]]]
(như bài #10 dẫn chứng).

Bài này chỉ có cách dùng cột phụ và sort (như bài #4 đã nêu), hoặc dùng Array.

Nhân tiện vụ này, hóa ra sau bao nhiêu năm vẫn chưa thấy có ai tìm ra kỹ thuật bỏ qua cái If này. Híc.
Nhấp chuột vào đây để mở rộng...
Ở bài #4 tôi có d ẫn các cách phụ của Delete, kể cả Union.
Trong bài ấy cũng cho biết là nguyên tắc Delete thì phải từ dưới lên trên. Tôi chỉ thấy code của thớt rác quá nên không buồn nêu ra là nó sai - không chỉ kém hiệu quả.

Những bất lợi của Union có thể cải tiến nếu biết kỹ thuật "chia để trị".

Ở bài ấy, tôi cũng có nói rằng Delete là giải pháp kém hiueej quả nhất.

Tôi không đề cập đến chuyện chép ra Array là vì phuonwg pháp này có rất nhiều ràng buộc.

Trước mắt thì phường pháp cột phụ và sort là khả quan nhất.
Bài này cũng dễ, dùng hàm Evaluate với công thức đơn giản đẻ ghi cột phụ rất nhanh.
 
Upvote 0
VetMini đã viết:
Trước mắt thì phường pháp cột phụ và sort là khả quan nhất.
Bài này cũng dễ, dùng hàm Evaluate với công thức đơn giản đẻ ghi cột phụ rất nhanh.
Nhấp chuột vào đây để mở rộng...
Như bài #10 đang dùng cột phụ ZZ đó ạ. Tốc độ cũng tương đối.
 
Upvote 0
hoangexcell đã viết:
View attachment 287873

Ô thế mình đang hiểu nhầm à. Theo bài tới đoạn như hình thì nghĩ là bắt bẽ chữ viết tắt: a thay cho Anh!
Nếu không phải thế thì thôi nhé. Xí xóa nhé!
Nhấp chuột vào đây để mở rộng...
Anh cho em xin lỗi nhé, khổ thân bé. Bé mới vào diễn đàn bị các anh mắng te tua. Em sẽ rút kinh nghiệm nè
Bài đã được tự động gộp:

Maika8008 đã viết:
Code bài #8 trên máy tôi chạy 20.000 dòng mất chừng 35 giây. Tuy nhiên với 40.000 dòng thì lâu quá, tôi chưa chờ thủ mất bao lâu.
Bài đã được tự động gộp:


Dùng Array thì nhanh nhưng sẽ phá hết công thức (nếu có)
Còn vụ if kia quả thực là chưa có gì thay thế cho gọn hết hả bạn?
Nhấp chuột vào đây để mở rộng...
Dạ cảm ơn anh nhiều ạ
Bài đã được tự động gộp:

bebo021999 đã viết:
Như bài #10 đang dùng cột phụ ZZ đó ạ. Tốc độ cũng tương đối.
Nhấp chuột vào đây để mở rộng...
Dạ em cũng nghĩ tới bước dùng cột phụ rồi mà nếu dùng cột phụ em cũng sẽ dùng vba để đánh số nên cũng mất nhiều thời gian
Bài đã được tự động gộp:

Maika8008 đã viết:
Sửa lại code chút xíu:
Rich (BB code): 
Sub AddRowsEvery10()
    Dim a, b As Double
    Dim i As Integer
    Dim rowCount As Integer, Rng As Range
   
    rowCount = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
   
    a = Timer
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
    For i = 10 To rowCount Step 10
        If Rng Is Nothing Then
            Set Rng = Rows(i + 1)
        Else
            Set Rng = Union(Rng, Rows(i + 1))
        End If
    Next i
    Rng.Insert
    b = Timer
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
    MsgBox Round(b - a, 2)
End Sub
Nhấp chuột vào đây để mở rộng...
Union là một cách mới đối với em, cảm ơn anh ạ
Bài đã được tự động gộp:

HeSanbi đã viết:

Ngân Nguyễn 9x​

Sử dụng Hàm Union gộp Range, để tiết kiệm tài nguyên bạn nhé
Tốt nhất nên khai báo ô bắt đầu.
JavaScript: 
Sub AddRowsEvery10()
  Dim a, i%, rowCount&, rg As Range, cell As Range
  Set cell = Sheet1.Range("A1")
  rowCount = cell.parent.UsedRange.Rows.count - cell.row + 1
  a = Timer
  With Application: .DisplayAlerts = False: .ScreenUpdating = False: .EnableEvents = False
    '------------------------------------
    For i = 11 To rowCount Step 10
      If Not rg Is Nothing Then Set rg = Union(rg, cell(i, 1)) Else Set rg = cell(i, 1)
    Next i
    If Not rg Is Nothing Then
      rg.EntireRow.Insert: MsgBox "Insert complete: " & Round(Timer - a, 2)
    Else
      MsgBox "Rows Empty!"
    End If
    '------------------------------------
    .DisplayAlerts = True: .ScreenUpdating = True: .EnableEvents = True
  End With
 
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ em cảm ơn nhiều nhiều ạ
Bài đã được tự động gộp:

Tuyệt vời quá các anh, mọi người có nhiều cách hay ghê
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
2
Trả lời
20
Đọc
332
shnhatha221108
S
S
Slicer không chuyển qua trạng thái mờ.
Trả lời
1
Đọc
33
ptm0412
ptm0412
K
Vẽ biểu đồ ứng suất bản thân và ứng suất gây lún = Excel
    • Thích
Trả lời
5
Đọc
13K
ptm0412
ptm0412
M
Bảng Pivot ko tự update theo dữ liệu và còn cộng thiếu số liệu.
Trả lời
6
Đọc
60
ptm0412
ptm0412
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2
Trả lời
36
Đọc
474
hoangtran1176
hoangtran1176
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom