Thú thật em cũng chưa hiểu yêu cầu là như thế nào.
If Len(Arr(i, n) & Arr(i, n + 1) & Arr(j, n) & Arr(j, n + 1)) > 0 Then Exit For
1/ Dòng trống: Theo data thí khá nhiều cụ thể dòng có số 17, 18 ...
Em test theo data thì chỉ có cặp 0:2 và đến 0:11074 mới thoả, chả biết yêu cầu tác giả thế nào nhưng Anh và Bác Sa có thể cho em 1 vd mà thoả với dòng 0 trên gần nhất, em sẽ tự suy luận.
Theo em thấy theo data thì của file kèm, file Tim_01Chương trình chúng ta đang có 3 vòng lặp; 2 Vòng ngoài miễn bàn đến.
Vòng thứ 3 phải duyệt từ cột đầu tiên (*) của 2 dòng có DL (dữ liệu) (Không kể cột 'A') cho đến cột lớn hơn trong 2 dòng đang xét có DL
(Giải thích dấu *: Nếu cột đầu tiên có thứ tự lẽ thì fải xét từ cột trước nó 1 cột.)
Ví dụ dòng 1 có 97 ô chứa DL bắt đầu từ C1 rãi cách khoảng cho đến HA1;
Dòng 8 có 78 ô chứa DL bắt đầu từ F8 cho đến iA8;
Nhưng vòng lặp 3 này ta chỉ xét từ cột 'B' cho tới cột 'iA' mà thôi. Vì:
(1) Tuy dòng 1 có dử liệu từ cột 'C' nhưng yêu cầu đề ra là xét 2 cặp ô bắt đầu từ cột 'B"
(2) Từ sau cột iA trở về cuối ở cả 2 dòng không còn ô nào chứa DL, nên khỏi tốn công xét tiếp.
Tuy tác giả khẳng định là DL thực không có hàng trống; nhưng thật ra, CSDL mà tác giả đưa lên có khoảng 1/10 số hàng rỗng tuếch;
( Mình cũng đã mất ~ nữa giây để loại chúng ra rồi.)
Bạn ThuNghi àh! Đúng là tốc độ maco bạn viết nhanh thật! Mình chỉ biết thốt lên kinh ngạc mà thôi (mình chạy mất khoảng 13 phút)! Các cặp bạn chép sang sheet3 đúng là thoả mãn điều kiện đấy! Bạn có thể hiểu Điều kiện là khi ghép cặp: không tính cột A thì cứ xét 2 cột thành một nhóm: (B;C), (D;E), (F;G),...,(IT;IU) nếu cứ có dữ liệu trong tất cả các nhóm là chép, còn nếu có 1 nhóm bất kì nào đó mà không có dữ liệu là bỏ qua! Mình không biết code của bạn viết có bỏ qua trường hợp nào không? Nhưng thật sự cảm ơn bạn! Bạn có thể chỉnh lại một chút được không sao cho dữ liệu khi chép sang sheet3 vẫn giữ nguyên định dạng ban đầu của các dòng như ở sheet1! (Ví dụ: ở sheet1, xét cột A: nếu mình thay đổi kí hiệu hay thay đổi màu kí hiệu cho dễ theo dõi thì khi chép sang sheet 3 cũng tuỳ biến theo giữ nguyên định dạng ban đầu. Vì mình thấy bạn mặc định ở cột A mất rồi).Thân ái! Một lần nữa xin cảm ơn bạn và mọi người! cảm ơn GPE!
1/ Bạn yên tâm, nếu yêu cầu "nếu có 1 nhóm bất kì nào đó mà không có dữ liệu là bỏ qua" thì 4 vòng if trên là OK rồi.
Yêu cầu này hoàn toàn khác với yêu cầu bốn ô cùng màu ít nhất có một ô có dữ liệu.
Vâng! Rất cảm ơn bạn đã quan tâm! Yêu cầu trên là thoáng hơn so với yêu cầu bốn ô cùng màu ít nhất có một ô có dữ liệu! Bạn có thể hiểu yêu cầu trong bốn ô cùng màu ít nhất một ô có dữ liệu tương đương với điều kiện sau: khi ghép cặp, không tính cột A thì cứ xét 2 cột thành một nhóm: (B;C), (D;E), (F;G),...,(IT;IU) nếu cứ có dữ liệu trong tất cả các nhóm là chép, còn nếu có 1 nhóm bất kì nào đó mà không có dữ liệu là bỏ qua! (vì yêu cầu này có vẻ chặt hơn và khó hơn nên mình mới nới rộng ra là khi ghép cặp: số cột không có dữ liệu liên tiếp không quá hai cột thì trường hợp này thỏa điều kiện)! Vâng, nếu bạn giúp được 1 trong 2 trường hợp là đều rất đáng quý bạn àh! Cảm ơn bạn!
Bạn ThuNghi ơi! Nếu bây giờ mình muốn thêm điều kiện là khi ghép cặp thì cột B không được có dữ liệu, sau đó mới xét đến 2 cột liên tiếp làm một nhóm (C;D), (E;F),...,(IU;IV) nếu có dữ liệu trong tất cả các nhóm này thì mới chép, còn nếu có 1 nhóm bất kì nào đó không có dữ liệu thì bỏ qua! Bạn có thể chỉnh lại code cho điều kiện đó được không? Mình mong sự hồi âm của bạn! Thân ái!
Sorry, code trước thiếu vòng lặp for n. Mới có
Phải là
Còn nếu theo yêu cầu nữa thì xét cái Arr01 trước nếu cột B="" thì tạo ra Arr02 và xét theo Arr02 này.
Option Explicit
Const endC As Long = 256
Dim endR As Long, i As Long, j As Long, n As Long, s As Long, k As Long
Dim Arr01(), Arr(), ArrKQ(), myArr()
Dim Timer_ As Double
Sub LocTwoRows2()
Timer_ = Timer
With Sheet1
endR = .Cells(65000, 1).End(xlUp).Row
Arr01 = .Range(.Cells(1, 1), .Cells(endR, endC))
End With
'tim arr co cot B <> blank
s = 0
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()
s = 0
ReDim ArrKQ(1 To 65000, 1 To 2)
For i = 1 To UBound(Arr) - 1
For j = i + 1 To UBound(Arr)
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
ArrKQ(s, 1) = i - 1
ArrKQ(s, 2) = j - 1
exit_forJ:
Next j
Next i
If s = 0 Then
MsgBox "Khong co du lieu OK"
GoTo escape
End If
ReDim myArr(1 To s * 3, 1 To endC)
n = 1
For i = 1 To s
myArr(n, 1) = ArrKQ(i, 1)
myArr(n + 1, 1) = ArrKQ(i, 2)
myArr(n + 2, 1) = ""
For k = 1 To endC
myArr(n, k + 1) = Arr(myArr(n, 1) + 1, k)
myArr(n + 1, k + 1) = Arr(myArr(n + 1, 1) + 1, k)
myArr(n + 2, k + 1) = ""
Next k
n = n + 3
Next i
With Sheet3
.Cells.ClearContents
.Range("A1").Resize(n - 1, endC) = myArr
End With
escape:
Erase Arr(), ArrKQ(), myArr()
MsgBox Timer - Timer_
End SubVâng! Mình không biết nói gì hơn ngoài lời chân thành cảm ơn bạn!
Nhầm 1 chút "cột B không có dữ liệu" bạn sửa code trên 1 chút
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 iNhưng hình như cũng có có cặp nào OK.
Cảm ơn bạn rất nhiều! Mình đã cho chạy thử nhưng chương trình hình như có lỗi bạn àh! mình thấy báo lỗi:
Vâng! Mình đã làm theo hướng dẫn và "rem" đã trở thành "Rem"! Nhưng sau đó vẫn thông báo lỗi: Run-tỉme error '9':
