Cải tiến tốc độ macro

[ThuNghi]

Dữ liệu của bạn có thay đổi gì không, tôi chạy thì nó kg có báo gì cả. Bạn đưa dữ liệu mới thì mới có thể tìm ra, dữ liệu lớn qu1 nên kg thể test nổi.

 

[sep_hatxel]

Dữ liệu của bạn có thay đổi gì không, tôi chạy thì nó kg có báo gì cả. Bạn đưa dữ liệu mới thì mới có thể tìm ra, dữ liệu lớn qu1 nên kg thể test nổi.

Với code ban đầu khi chưa có thêm điều kiện cột B trống thì mình thấy chạy rất ổn và nhanh! Khi thêm điều kiện cột B trống thì mình đã chỉnh lại code theo bạn nhưng vẫn thông báo lỗi bạn àh, mặc dù vẫn số liệu đó! Mình test lại với số liệu ít hơn và chỉ để có 2 dòng đầu thoả mãn nhưng code không tìm ra! Mình thấy ngại quá, vì đã làm phiền nhiều đến các bạn! Mình cảm ơn các bạn rất nhiều!

 

[ThuNghi]

Với code ban đầu khi chưa có thêm điều kiện cột B trống thì mình thấy chạy rất ổn và nhanh! Khi thêm điều kiện cột B trống thì mình đã chỉnh lại code theo bạn nhưng vẫn thông báo lỗi bạn àh, mặc dù vẫn số liệu đó! Mình test lại với số liệu ít hơn và chỉ để có 2 dòng đầu thoả mãn nhưng code không tìm ra! Mình thấy ngại quá, vì đã làm phiền nhiều đến các bạn! Mình cảm ơn các bạn rất nhiều!

Bạn hãy đưa file có data khoảng 10 dòng và trong đó có khoảng vài cặp đúng (chính xác), kq đó bạn để ở sh khác.
Mình sẽ test thử.

 

[sep_hatxel]

Bạn hãy đưa file có data khoảng 10 dòng và trong đó có khoảng vài cặp đúng (chính xác), kq đó bạn để ở sh khác.
Mình sẽ test thử.

Vâng! Cảm ơn bạn! mình gửi cho bạn file data nhờ bạn kiểm tra giúp! Cảm ơn bạn!

 

[ThuNghi]

Vâng! Cảm ơn bạn! mình gửi cho bạn file data nhờ bạn kiểm tra giúp! Cảm ơn bạn!

Dữ liệu lớn quá, test gần 3 phút. Hy vọng kỳ này OK.
Bạn có thể thay thông số fR ở đầu code. (dòng đầu có dữ liệu).

Option Explicit
Const endC As Long = 256: Const fR As Long = 4
Dim endR As Long, i As Long, j As Long, n As Long, s As Long, k As Long, eR As Long
Dim Arr01(), Arr(), ArrKQ(), myArr()
Dim Timer_ As Double
Sub LocTwoRows()
Timer_ = Timer
With Sheet1
  endR = .Cells(65000, 1).End(xlUp).Row
  Arr01 = .Range(.Cells(fR, 1), .Cells(endR, endC))
End With
'Tim va tao arr co cot B <> blank'
s = 0: endR = endR - fR + 1
ReDim Arr(1 To endR, 1 To endC)
For i = 1 To endR
  If Len(Arr01(i, 2)) = 0 Then
    s = s + 1
    For k = 1 To endC
      Arr(s, k) = Arr01(i, k)
    Next k
  End If
Next i
Erase Arr01()
'Tao nhung cap dong thoa dk'
eR = s: s = 0
ReDim ArrKQ(1 To 65000, 1 To 2)
For i = 1 To eR - 1
  For j = i + 1 To eR
    For n = 3 To endC - 1 Step 2
      If Len(Arr(i, n)) = 0 Then
        If Len(Arr(i, n + 1)) = 0 Then
          If Len(Arr(j, n)) = 0 Then
            If Len(Arr(j, n + 1)) = 0 Then
        GoTo exit_forJ
      End If: End If: End If: End If
    Next n
    s = s + 1
    'so tt dong thoa dk trong Arr'
    ArrKQ(s, 1) = i 'dong 1 cua Arr'
    ArrKQ(s, 2) = j 'dong 2 cua Arr'
exit_forJ:
  Next j
Next i
If s = 0 Or s > 20000 Then 'neu qua 20000 rows thi nhan 3 qua lon'
  MsgBox "Du lieu khong OK"
  GoTo Escape
End If

ReDim myArr(1 To s * 3, 1 To endC)
n = 1
For i = 1 To s
  'gan vao cot 1 theo kq dong ArrKQ tham chieu Arr'
  myArr(n, 1) = Arr(ArrKQ(i, 1), 1)
  myArr(n + 1, 1) = Arr(ArrKQ(i, 2), 1)
  myArr(n + 2, 1) = ""
  'gan vao cot 2- > cuoi'
  For k = 2 To endC
    myArr(n, k) = Arr(ArrKQ(i, 1), k)
    myArr(n + 1, k) = Arr(ArrKQ(i, 2), k)
    myArr(n + 2, k) = ""
  Next k
  n = n + 3
Next i
With Sheet3.Range("A" & fR)
  .Resize(65000, endC).ClearContents
  .Resize(n - 1, endC) = myArr
End With
Escape:
Erase Arr(), ArrKQ(), myArr()
MsgBox Timer - Timer_
End Sub

Không nên đặt tên file hay tên sh là tiếng Việt và có khoảng trắng.

 

[sep_hatxel]

Dữ liệu lớn quá, test gần 3 phút. Hy vọng kỳ này OK.
Bạn có thể thay thông số fR ở đầu code. (dòng đầu có dữ liệu).

Option Explicit
Const endC As Long = 256: Const fR As Long = 4
Dim endR As Long, i As Long, j As Long, n As Long, s As Long, k As Long, eR As Long
Dim Arr01(), Arr(), ArrKQ(), myArr()
Dim Timer_ As Double
Sub LocTwoRows()
Timer_ = Timer
With Sheet1
endR = .Cells(65000, 1).End(xlUp).Row
Arr01 = .Range(.Cells(fR, 1), .Cells(endR, endC))
End With
'Tim va tao arr co cot B <> blank'
s = 0: endR = endR - fR + 1
ReDim Arr(1 To endR, 1 To endC)
For i = 1 To endR
If Len(Arr01(i, 2)) = 0 Then
s = s + 1
For k = 1 To endC
Arr(s, k) = Arr01(i, k)
Next k
End If
Next i
Erase Arr01()
'Tao nhung cap dong thoa dk'
eR = s: s = 0
ReDim ArrKQ(1 To 65000, 1 To 2)
For i = 1 To eR - 1
For j = i + 1 To eR
For n = 3 To endC - 1 Step 2
If Len(Arr(i, n)) = 0 Then
If Len(Arr(i, n + 1)) = 0 Then
If Len(Arr(j, n)) = 0 Then
If Len(Arr(j, n + 1)) = 0 Then
GoTo exit_forJ
End If: End If: End If: End If
Next n
s = s + 1
'so tt dong thoa dk trong Arr'
ArrKQ(s, 1) = i 'dong 1 cua Arr'
ArrKQ(s, 2) = j 'dong 2 cua Arr'
exit_forJ:
Next j
Next i
If s = 0 Or s > 20000 Then 'neu qua 20000 rows thi nhan 3 qua lon'
MsgBox "Du lieu khong OK"
GoTo Escape
End If
 
ReDim myArr(1 To s * 3, 1 To endC)
n = 1
For i = 1 To s
'gan vao cot 1 theo kq dong ArrKQ tham chieu Arr'
myArr(n, 1) = Arr(ArrKQ(i, 1), 1)
myArr(n + 1, 1) = Arr(ArrKQ(i, 2), 1)
myArr(n + 2, 1) = ""
'gan vao cot 2- > cuoi'
For k = 2 To endC
myArr(n, k) = Arr(ArrKQ(i, 1), k)
myArr(n + 1, k) = Arr(ArrKQ(i, 2), k)
myArr(n + 2, k) = ""
Next k
n = n + 3
Next i
With Sheet3.Range("A" & fR)
.Resize(65000, endC).ClearContents
.Resize(n - 1, endC) = myArr
End With
Escape:
Erase Arr(), ArrKQ(), myArr()
MsgBox Timer - Timer_
End Sub

Không nên đặt tên file hay tên sh là tiếng Việt và có khoảng trắng.

Cảm ơn bạn rất nhiều! Chạy tốt lắm bạn àh! Tuyệt quá! Vui quá bạn àh! Hôm nay mình cũng mày mò sửa lại đoạn code ban đầu của mình cũng chạy được, nhưng lại không biết làm sao sửa lại như thế nào để thoả mãn thêm điều kiện là cột B trống dữ liệu như của bạn! Một lần nữa cảm ơn bạn rất nhiều! Mình xin mạn phép đưa đoạn code mình mày mò:

Dim Mang(12000, 12000) As Boolean
Sub Doc_Mang()
Dim i As Integer, j As Integer
For i = 1 To 12000
For j = 1 To 254
Mang(i, j) = False
If Sheet1.Cells(i, j + 1) <> "" Then Mang(i, j) = True
Next
Next

j = 5
For i = 12000 To 5 Step -1
If Sheet2.Cells(i, 1) <> "" Then
j = i
Exit For
End If
Next
Sheet2.Range("A1:IV1").Copy
For j = 5 To i
Sheet2.Range("A" & j & ":IV" & j).PasteSpecial (xlPasteAll)
Next
End Sub
Function fKiemTra(i, j As Integer) As Boolean
Dim k As Integer
Dim KQ As Boolean
k = 1
KQ = True
Do While k < 254
If (Mang(i, k) = False) And (Mang(i, k + 1) = False) And (Mang(j, k) = False) And (Mang(j, k + 1) = False) Then
KQ = False
Exit Do
End If
k = k + 2
Loop
'MsgBox i & " - " & j & ":" & k
fKiemTra = KQ
End Function
Sub Tim_kiem()
Dim i As Integer, j As Integer
Dim TT As Integer, SR As String
Doc_Mang

TT = 5
For i = 1 To 11999
For j = i + 1 To 12000
If fKiemTra(i, j) = True Then
SR = "A" & i & ":IU" & i
Sheet1.Range(SR).Copy
SR = "A" & TT & ":IU" & TT
Sheet2.Range(SR).PasteSpecial (xlPasteAll)
TT = TT + 1

SR = "A" & j & ":IU" & j
Sheet1.Range(SR).Copy
SR = "A" & TT & ":IU" & TT
Sheet2.Range(SR).PasteSpecial (xlPasteAll)
TT = TT + 2
End If
Next
Next
End Sub

 

[huuthang_bd]

Chào bạn sep_hatxel.
Tôi nhận được mail của bạn nhưng không thể gửi file cho bạn qua email được. Tôi post lên đây vậy.
Do dung lượng upload có hạn nên tôi không để nhiều dữ liệu. Bạn tải file về và tự thêm dữ liệu vào để test.

P/S: Code trong file tôi sửa lại từ code của bạn ThuNghi.

 

[sep_hatxel]

Chào bạn sep_hatxel.
Tôi nhận được mail của bạn nhưng không thể gửi file cho bạn qua email được. Tôi post lên đây vậy.
Do dung lượng upload có hạn nên tôi không để nhiều dữ liệu. Bạn tải file về và tự thêm dữ liệu vào để test.

P/S: Code trong file tôi sửa lại từ code của bạn ThuNghi.

Vâng! Cảm ơn bạn Huuthang_bd rất nhiều! Đúng là sau mỗi lần cải tiến thì tốc độ của Maco nhanh lên rất nhiều lần! Chân Thành cảm ơn bạn! Chúc cho những ngày mới thắng lợi!

 

[sep_hatxel]

Dữ liệu lớn quá, test gần 3 phút. Hy vọng kỳ này OK.
Bạn có thể thay thông số fR ở đầu code. (dòng đầu có dữ liệu).

Option Explicit
Const endC As Long = 256: Const fR As Long = 4
Dim endR As Long, i As Long, j As Long, n As Long, s As Long, k As Long, eR As Long
Dim Arr01(), Arr(), ArrKQ(), myArr()
Dim Timer_ As Double
Sub LocTwoRows()
Timer_ = Timer
With Sheet1
endR = .Cells(65000, 1).End(xlUp).Row
Arr01 = .Range(.Cells(fR, 1), .Cells(endR, endC))
End With
'Tim va tao arr co cot B <> blank'
s = 0: endR = endR - fR + 1
ReDim Arr(1 To endR, 1 To endC)
For i = 1 To endR
If Len(Arr01(i, 2)) = 0 Then
s = s + 1
For k = 1 To endC
Arr(s, k) = Arr01(i, k)
Next k
End If
Next i
Erase Arr01()
'Tao nhung cap dong thoa dk'
eR = s: s = 0
ReDim ArrKQ(1 To 65000, 1 To 2)
For i = 1 To eR - 1
For j = i + 1 To eR
For n = 3 To endC - 1 Step 2
If Len(Arr(i, n)) = 0 Then
If Len(Arr(i, n + 1)) = 0 Then
If Len(Arr(j, n)) = 0 Then
If Len(Arr(j, n + 1)) = 0 Then
GoTo exit_forJ
End If: End If: End If: End If
Next n
s = s + 1
'so tt dong thoa dk trong Arr'
ArrKQ(s, 1) = i 'dong 1 cua Arr'
ArrKQ(s, 2) = j 'dong 2 cua Arr'
exit_forJ:
Next j
Next i
If s = 0 Or s > 20000 Then 'neu qua 20000 rows thi nhan 3 qua lon'
MsgBox "Du lieu khong OK"
GoTo Escape
End If
 
ReDim myArr(1 To s * 3, 1 To endC)
n = 1
For i = 1 To s
'gan vao cot 1 theo kq dong ArrKQ tham chieu Arr'
myArr(n, 1) = Arr(ArrKQ(i, 1), 1)
myArr(n + 1, 1) = Arr(ArrKQ(i, 2), 1)
myArr(n + 2, 1) = ""
'gan vao cot 2- > cuoi'
For k = 2 To endC
myArr(n, k) = Arr(ArrKQ(i, 1), k)
myArr(n + 1, k) = Arr(ArrKQ(i, 2), k)
myArr(n + 2, k) = ""
Next k
n = n + 3
Next i
With Sheet3.Range("A" & fR)
.Resize(65000, endC).ClearContents
.Resize(n - 1, endC) = myArr
End With
Escape:
Erase Arr(), ArrKQ(), myArr()
MsgBox Timer - Timer_
End Sub

Không nên đặt tên file hay tên sh là tiếng Việt và có khoảng trắng.

Bác ThuNghi ơi! Lâu rồi lại làm phiền tới bác! Với code này thì mình muốn test lại trên excel2007 với hàng dữ liệu tối đa nhất có thể thì mình có thể làm được bao nhiêu hàng và sửa code này như thế nào ạ? (Ví dụ mình muốn test với dữ liệu lên tới 800000 hàng thì mình có làm được không ạ?)! Cảm ơn bác! Chúc bác luôn mạnh khoẻ!