Mình muốn copy dữ liệu từ trang 1 sang trang 2 với điều kiện là cứ 2 dòng bất kì ở trang 1 khi ghép với nhau thành 1 cặp phải thoả mãn trong 4 ô cùng màu (2cột liên tiếp) có ít nhất một ô chứa số liệu được nhập vào! Bạn xem ví dụ minh hoạ ở trang 2 bản copy (cặp 0-2 là thoả mãn). Mình đã nhờ GPE giải đáp, được bạn SA_DQ và HYen17 giúp đỡ nhiệt tình ở mục trung tâm giải thích code nhưng tốc độ của maco chạy hơi lâu, với số liệu hiện thời mình nhập vào thì mất gần 5giờ đồng hồ! Mong GPE giúp đỡ cải tiến tốc độ của maco! Cảm ơn nhiều!
Bạn dùng macro này để tái cấu trúc lại dữ liệu & giảm được 1/10 thời gian, chắc vậy
PHP:
Option Explicit
Sub ConvertRows()
Dim WF As Object, Cls As Range
Dim eRw As Long, Jj As Long
Sheet1.Select
eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row: Sheet2.Rows("2:2").ClearContents
With Application
Set WF = .WorksheetFunction: .ScreenUpdating = False
End With
For Each Cls In [B1].Resize(eRw)
Cls.Offset(, -1).Value = "A" & Right("00" & WF.Count(Cls.Resize(, 255)), 3) _
& Right("0000" & Cls.Offset(, -1).Value, 5)
Next Cls
Cells.Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
Option Explicit
Sub ConvertRows()
Dim WF As Object, Cls As Range
Dim eRw As Long, Jj As Long
Sheet1.Select
eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row: Sheet2.Rows("2:2").ClearContents
With Application
Set WF = .WorksheetFunction: .ScreenUpdating = False
End With
For Each Cls In [B1].Resize(eRw)
Cls.Offset(, -1).Value = "A" & Right("00" & WF.Count(Cls.Resize(, 255)), 3) _
& Right("0000" & Cls.Offset(, -1).Value, 5)
Next Cls
Cells.Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub
Vì dữ liệu của bạn có đến hơn 1/10 là những hàng rỗng
Nếu không loại riêng chúng nó ra 1 chổ, ta sẽ tốn thời gian khảo sát nó;
Sau khi chạy xong macro này chưa đến 1/2 gy, ta đã loại bỏ được (11344 - 9475) dòng ta không cần đếm xỉa tới;
Tất nhiên ta có thể tìm mã A00001869 là dòng trống đầu tiên trong các dòng trống để loại nó ra trong quá trình tìm kiếm mà trước đây bạn đã chạy trong 5 giờ đó.
Tất nhiên macro cũ cũng cần chỉnh sửa 1 tẹo.
Việc bây giờ là bạn chạy macro & hiểu macro đã làm gì & bạn hiểu nó rồi thì có chấp nhận việc nó làm hay không.
Lúc đó chúng ta tiếp tục & mình sẽ cải tiến tiếp macro tìm kiếm để nó rút thêm về thời gian. . .
Vâng bạn àh! Tại vì file đưa lên diễn đàn với dung lượng có giới hạn! Nên mình phải xoá bớt đi số liệu của rất nhiều dòng cho giảm dung lượng mới gửi lên được diễn đàn! Trong thực tế dòng nào cũng có số liệu! Thân ái! Chúc ngày mới thắng lợi!
File đó có nhiều DL (dữ liệu) thực nhất nhưng dung lượng không vượt mức cho fép của diễn đàn;
( *) Trong file không nên tô màu nền nhiều như vậy; Hình như mình có đọc đâu đó rằng tô như vậy cũng sẽ gây nặng file; Thay vì bạn tô 4 cột DL ta chỉ nên tô 1 cột đầu) trong 4 cột đó thôi; Thậm chí ta chỉ tô ô đầu tiên của cột í mà thôi bạn à.
Theo mình, bạn chạy macro mà mìn gời bên trên; xóa các dòng trống đó đi & thay vào chổ bị xóa là những dòng dữ liệu thực (Nếu có thời gian bạn đánh lại STT của dòng như lúc chưa chạy macro; Rồi bạn đưa lên lại;
Cộng đồng chúng ta sẽ làm việc với CSDL gần thực hơn của bạn.
Rất mong bạn đáp ứng & xem đây là những đòi hỏi không quá lố!
Mình muốn copy dữ liệu từ trang 1 sang trang 2 với điều kiện là cứ 2 dòng bất kì ở trang 1 khi ghép với nhau thành 1 cặp phải thoả mãn trong 4 ô cùng màu (2cột liên tiếp) có ít nhất một ô chứa số liệu được nhập vào! Bạn xem ví dụ minh hoạ ở trang 2 bản copy (cặp 0-2 là thoả mãn). Mình đã nhờ GPE giải đáp, được bạn SA_DQ và HYen17 giúp đỡ nhiệt tình ở mục trung tâm giải thích code nhưng tốc độ của maco chạy hơi lâu, với số liệu hiện thời mình nhập vào thì mất gần 5giờ đồng hồ! Mong GPE giúp đỡ cải tiến tốc độ của maco! Cảm ơn nhiều!
Thú thật chả hiểu yêu cầu bài này áp dụng thực tế thế nào. Minh diễn nôm yêu cầu lại nhé.
1/ Duyệt từ dòng i so với các dòng còn lại (i=1). Và tiếp tục i=i+1, i=1 to endR
2/ Nếu các cells(i, 2n) và cells(i, 2n+1) và cells(k, 2n) và cells(k, 2n+1) khác rỗng thì lấy dòng i và k, k=1 and <=endr. n =1 to endC
endR: dòng cuối
endC: cột cuối
Có cần thiết phải nhìn theo màu không, màu tô có quy luật 2n và 2n+1 ?
Bạn giải thích yêu cầu nhé.
Đem lần lượt từng dòng dữ liệu, bắt đầu từ dòng 1 so với từng dòng còn lại;
Xét từng cặp 4 ô liền nhau của 2 dòng bắt đầu từ cột thứ 2 (Như B1C1 & B9C9,. . .(So 1 với 9)). Nếu 1 trong 4 ô này có giá trị thì chép cả cặp dòng sang trang mới.
Đem lần lượt từng dòng dữ liệu, bắt đầu từ dòng 1 so với từng dòng còn lại;
Xét từng cặp 4 ô liền nhau của 2 dòng bắt đầu từ cột thứ 2 (Như B1C1 & B9C9,. . .(So 1 với 9)). Nếu 1 trong 4 ô này có giá trị thì chép cả cặp dòng sang trang mới.
Tạm thời em làm với 100 cột, kết quả sẽ cặp số gán số dòng vào sheet3. OK sẽ làm tiếp.
PHP:
Option Explicit
Const endC As Long = 100
Dim endR As Long, i As Long, j As Long, n As Long, s As Long
Dim Arr(), ArrKQ()
Dim T
Sub LocTwoRows()
T = Timer
With Sheet1
endR = .Cells(65000, 1).End(xlUp).Row
Arr = .Range(.Cells(1, 2), .Cells(endR, endC))
End With
s = 0
ReDim ArrKQ(1 To endR, 1 To 2)
For i = 1 To endR - 1
For j = i + 2 To endR
For n = 1 To endC / 2 - 1 Step 2
If Len(Arr(i, n)) + Len(Arr(i, n + 1)) + Len(Arr(j, n)) + Len(Arr(j, n + 1)) = 0 Then
GoTo exit_for
End If
Next n
s = s + 1
ArrKQ(s, 1) = i - 1
ArrKQ(s, 2) = j - 1
exit_for:
Next j
Next i
If s > 10000 Then s = 10000
Sheet3.Range("A1").Resize(s, 2) = ArrKQ
Erase Arr(), ArrKQ()
MsgBox Timer - T
End Sub
Theo mình thì ThuNghi có thêm mảng vô chương trình;
Đề nghị ThuNghi mấy việc như sau:
(*) Hằng số EndC => 255
(*) Để biết tốc độ của mỗi trình, mình đề nghị cho chạy macro nào cũng 2 fút (Sau đó ghi ngay biến i & j vô đâu đó & thoát) Có vậy ta sẽ biết được tốc độ của 1 macro;
(*) Mình cũng đã thử xác định ô cuối có dữ liệu của mỗi dòng & ô đầu tiên có dữ liệu (không kể cột 'A'), lúc đó code dài hơn, nhưng có vẻ như tăng tốc hơn!
(*) File của chủ topic đưa lên, nếu mình bỏ hết màu nền thì thay vì > 20M sẽ còn gần 10M thôi.
Mình vẫn mong có file gần với thực tế từ tác gia topic, để vấn đề có tính thực tiển nhiều hơn.
Theo mình thì ThuNghi có thêm mảng vô chương trình;
Đề nghị ThuNghi mấy việc như sau:
(*) Hằng số EndC => 255
(*) Để biết tốc độ của mỗi trình, mình đề nghị cho chạy macro nào cũng 2 fút (Sau đó ghi ngay biến i & j vô đâu đó & thoát) Có vậy ta sẽ biết được tốc độ của 1 macro;
(*) Mình cũng đã thử xác định ô cuối có dữ liệu của mỗi dòng & ô đầu tiên có dữ liệu (không kể cột 'A'), lúc đó code dài hơn, nhưng có vẻ như tăng tốc hơn!
(*) File của chủ topic đưa lên, nếu mình bỏ hết màu nền thì thay vì > 20M sẽ còn gần 10M thôi.
Mình vẫn mong có file gần với thực tế từ tác gia topic, để vấn đề có tính thực tiển nhiều hơn.
Em cũng không biết cột IT (254) chỉ duy nhất 1 màu thì làm sao mà xét 4 cột, và có những vùng phải xét tới 4 cột => 8 ô.
Em nghĩ có thể tác giả có sai cái gì, nếu từ cột 240 -> 256 mà lô gích như vậy thì bỏ qua xét màu.
Còn nếu phải xét theo màu thì em sẽ xét màu hết các cột và gán tham số cho cột.
Em thấy kết quả tác giả yêu cầu bên sheet2 chỉ đến cột CW (101)
Và nhìn qua data cũng thấy rằng dòng 0 và 11 thì không thỏa. R1:S1 và R12:S12 là rỗng => sao lại lấy.
Theo yêu cầu của tác giả, nếu dữ liệu 1000 dòng thì mỗi dòng sẽ so với 999 dòng còn lại để tìm đôi tìm lứa. Tổng cộng dù muốn dù không sẽ phải dò n(n-1)/2 lần = 499.500 lần.
Ngoài ra nếu 200 cột thì phải so sánh 200 cặp ô, vậy số lần so sánh để xét điều kiện là 99.900.000 lần
Riêng 1 cái này cũng đã là chậm, dùng mảng hay bất cứ phương pháp nào cũng phải chạy đủ bằng đó lần. Giảm được bao nhiêu thời gian thì giảm, nhưng giảm xuống dưới 5 phút là điều không tưởng.
Mình dùng macro này trước & sau cải tiến có cải thiện
PHP:
Option Explicit
Sub CountValueToColumnA()
Dim WF, Rng As Range, Cls As Range, cRg As Range, Rg1 As Range, Rg2 As Range
Dim eRw As Long, jJ As Long, Ww As Long, zZ As Integer
Dim Timer_ As Double, CCot As Integer, EndCol As Integer
Timer_ = Timer: Sheet1.Select
eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Sheet2.Rows("2:2").ClearContents
Sheet2.[A4].Resize(eRw, 256).Clear: Application.ScreenUpdating = False
Set Rng = [B1].Resize(eRw): Set WF = Application.WorksheetFunction
Rng.Interior.ColorIndex = 0
For Each Cls In Rng
If WF.Count(Cls.Resize(, 255)) = 0 Then Cls.Offset(, -1).Interior.ColorIndex = 38
Next Cls '0.484'
For jJ = 1 To eRw - 1
If Cells(jJ, "A").Interior.ColorIndex < 9 Then
20 With Cells(jJ, "IV")
If .Value <> "" Then EndCol = 256 Else EndCol = .End(xlToLeft).Column
21 End With
For Ww = jJ + 1 To eRw
If Cells(Ww, "A").Interior.ColorIndex < 9 Then
22 With Cells(Ww, "IV")
If .Value = "" Then CCot = .End(xlToLeft).Column Else CCot = 256
End With
25 If CCot > EndCol Then CCot = EndCol
For zZ = 2 To CCot Step 2 '<=|'
Set Rg1 = Cells(jJ, zZ).Resize(, 2)
Set Rg2 = Cells(Ww, zZ).Resize(, 2)
If WF.Sum(Union(Rg1, Rg2)) < 1 Then Exit For
If zZ > 253 Then
With Sheet2.[a65500].End(xlUp).Offset(2)
Rg1.EntireRow.Copy Destination:=.Cells(1, 1)
Rg2.EntireRow.Copy Destination:=.Cells(2, 1)
End With
[iv2].End(xlToLeft).Offset(, 1).Value = Timer - Timer_
End If
Next zZ
End If
Next Ww
End If
If Timer - Timer_ > 120 Then
With Sheet3.[b65500].End(xlUp).Offset(1)
.Value = jJ: .Offset(, 1).Value = "Ver." & " 2"
Exit Sub
End With
End If
Next jJ
End Sub
(*) Trước khi cải tiến trong 120 gy duyệt được 132 dòng hoàn chỉnh;
(*) Sau cải tiến (Thêm các dòng lệnh có đánh số, thì bằng ấy thời gian duyệt được 159 dòng hoàn chỉnh;
Cải tiến là duyệt đến ô cuối cùng trước tiên trong 2 dòng có dữ liệu mà thôi.
Mời ThuNghi xem kết quả duyệt được chép ở Sheet2 (để khỏi lấn cấn về đề bài)
ThuNghi có thể thay mảng vô macro này xem có khả quan gì không?! (Với mảng í mà)
(*) Tất nhiên ta cũng có thể giảm thời gian nữa cũng bằng cách tìm ô đầu tiên lớn nhất của 1 trong 2 dòng có dữ liệu để bắt đầu duyệt (chứ chúng ta không duyệt từ cột 2 nữa)
Em cũng không biết cột IT (254) chỉ duy nhất 1 màu thì làm sao mà xét 4 cột, và có những vùng phải xét tới 4 cột => 8 ô.
Em nghĩ có thể tác giả có sai cái gì, nếu từ cột 240 -> 256 mà lô gích như vậy thì bỏ qua xét màu.
Còn nếu phải xét theo màu thì em sẽ xét màu hết các cột và gán tham số cho cột.
Em thấy kết quả tác giả yêu cầu bên sheet2 chỉ đến cột CW (101)
Và nhìn qua data cũng thấy rằng dòng 0 và 11 thì không thỏa. R1:S1 và R12:S12 là rỗng => sao lại lấy.
Vâng! Cảm ơn rất nhiều GPE đã giúp đỡ! Mình tô màu cho dễ theo dõi thôi ạ! Vấn đề mấu chốt ở đây là tìm ghép 2 dòng dữ liệu sao cho khi ghép trống nhiều nhất không quá 2 cột liên tiếp!
Vâng! Cảm ơn rất nhiều GPE đã giúp đỡ! Mình tô màu cho dễ theo dõi thôi ạ! Vấn đề mấu chốt ở đây là tìm ghép 2 dòng dữ liệu sao cho khi ghép trống nhiều nhất không quá 2 cột liên tiếp!
Vâng bạn àh! Mình thành thật xin lỗi! 4 cột đó mình tô nhầm màu! Nhưng mình có thể không cần để ý đến màu tô cũng được bạn àh! Mình chỉ cần ghép sao cho 2 dòng với nhau thoả mãn số liệu nhập vào không được trống quá 2 cột liên tiếp! Chân thành cảm ơn bạn! Và mình có thể chỉ cần xét dữ liệu nhập đến cột IU!
Option Explicit
Sub CountValueToColumnA()
Dim WF, Rng As Range, Cls As Range, cRg As Range, Rg1 As Range, Rg2 As Range
Dim eRw As Long, jJ As Long, Ww As Long, zZ As Integer
Dim Timer_ As Double, CCot As Integer, EndCol As Integer
Timer_ = Timer: Sheet1.Select
eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Sheet2.Rows("2:2").ClearContents
Sheet2.[A4].Resize(eRw, 256).Clear: Application.ScreenUpdating = False
Set Rng = [B1].Resize(eRw): Set WF = Application.WorksheetFunction
Rng.Interior.ColorIndex = 0
For Each Cls In Rng
If WF.Count(Cls.Resize(, 255)) = 0 Then Cls.Offset(, -1).Interior.ColorIndex = 38
Next Cls '0.484'
For jJ = 1 To eRw - 1
If Cells(jJ, "A").Interior.ColorIndex < 9 Then
20 With Cells(jJ, "IV")
If .Value <> "" Then EndCol = 256 Else EndCol = .End(xlToLeft).Column
21 End With
For Ww = jJ + 1 To eRw
If Cells(Ww, "A").Interior.ColorIndex < 9 Then
22 With Cells(Ww, "IV")
If .Value = "" Then CCot = .End(xlToLeft).Column Else CCot = 256
End With
25 If CCot > EndCol Then CCot = EndCol
For zZ = 2 To CCot Step 2 '<=|'
Set Rg1 = Cells(jJ, zZ).Resize(, 2)
Set Rg2 = Cells(Ww, zZ).Resize(, 2)
If WF.Sum(Union(Rg1, Rg2)) < 1 Then Exit For
If zZ > 253 Then
With Sheet2.[a65500].End(xlUp).Offset(2)
Rg1.EntireRow.Copy Destination:=.Cells(1, 1)
Rg2.EntireRow.Copy Destination:=.Cells(2, 1)
End With
[iv2].End(xlToLeft).Offset(, 1).Value = Timer - Timer_
End If
Next zZ
End If
Next Ww
End If
If Timer - Timer_ > 120 Then
With Sheet3.[b65500].End(xlUp).Offset(1)
.Value = jJ: .Offset(, 1).Value = "Ver." & " 2"
Exit Sub
End With
End If
Next jJ
End Sub
(*) Trước khi cải tiến trong 120 gy duyệt được 132 dòng hoàn chỉnh;
(*) Sau cải tiến (Thêm các dòng lệnh có đánh số, thì bằng ấy thời gian duyệt được 159 dòng hoàn chỉnh;
Cải tiến là duyệt đến ô cuối cùng trước tiên trong 2 dòng có dữ liệu mà thôi.
Mời ThuNghi xem kết quả duyệt được chép ở Sheet2 (để khỏi lấn cấn về đề bài)
ThuNghi có thể thay mảng vô macro này xem có khả quan gì không?! (Với mảng í mà)
(*) Tất nhiên ta cũng có thể giảm thời gian nữa cũng bằng cách tìm ô đầu tiên lớn nhất của 1 trong 2 dòng có dữ liệu để bắt đầu duyệt (chứ chúng ta không duyệt từ cột 2 nữa)
Vâng bạn àh! Mình thành thật xin lỗi! 4 cột đó mình tô nhầm màu! Nhưng mình có thể không cần để ý đến màu tô cũng được bạn àh! Mình chỉ cần ghép sao cho 2 dòng với nhau thoả mãn số liệu nhập vào không được trống quá 2 cột liên tiếp! Chân thành cảm ơn bạn! Và mình có thể chỉ cần xét dữ liệu nhập đến cột IU!
Vậy bạn dùng thử code sau, tôi chạy hết 150 s
Có thể rút gọn phần gán vào, nhưng do test nên để thành phần.
Kết quả gán vào sh 3
PHP:
Option Explicit
Const endC As Long = 255
Dim endR As Long, i As Long, j As Long, n As Long, s As Long, k As Long
Dim Arr(), ArrKQ(), myArr()
Dim Timer_ As Double
Sub LocTwoRows()
Timer_ = Timer
With Sheet1
endR = .Cells(65000, 1).End(xlUp).Row
Arr = .Range(.Cells(1, 2), .Cells(endR, endC))
End With
s = 0
ReDim ArrKQ(1 To endR, 1 To 2)
For i = 1 To endR - 1
For j = i + 1 To endR
For n = 1 To (endC - 1) / 2 - 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_for
End If: End If: End If: End If
Next n
s = s + 1
ArrKQ(s, 1) = i - 1
ArrKQ(s, 2) = j - 1
exit_for:
Next j
Next i
ReDim myArr(1 To s * 3, 1 To 255)
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 254
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
Sheet3.Range("A1").Resize(n - 1, 255) = myArr
Erase Arr(), ArrKQ(), myArr()
MsgBox Timer - Timer_
End Sub
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_for
End If: End If: End If: End If
Đoạn code này có nghĩa là hễ gặp nhóm 4 ô liền kề bắt đầu từ cột chẵn không chứa trị thì thoát;
Nhưng điều kiện đề bài thì:
Hễ gặp bất kỳ 4 ô này có 1 ô chứa trị thì 2 dòng đó là nghiệm & được chép sang trang mới.
Nên fải duyệt đến cuối; Còn thoát là khi chúng là nghiệm cần chép.
[QUOTE]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_for
End If: End If: End If: End If[/QUOTE]
Hình như phải là > 0 thì thoát trước hạn mới phải?
Mà sao không dùng 1 If thôi?
PHP:
If Len(Arr(i, n) & Arr(i, n + 1) & Arr(j, n) & Arr(j, n + 1)) > 0 Then Exit For
Thú thật em cũng chưa hiểu yêu cầu là như thế nào.
Vậy theo Bác Sa và Anh Mỹ thì thế nào mới là điều kiện.
Xin cho em cụ thể theo data. Xin cám ơn.
Em đã gán code vào và chạy thử ra KQ ở sh 3 cũng trùng như code Bác Sa (sh 2).
Và còn
PHP:
If Len(Arr(i, n) & Arr(i, n + 1) & Arr(j, n) & Arr(j, n + 1)) > 0 Then Exit For
Thì em tách ra làm 4 if vẫn nhanh hơn dồn lại với dữ liệu lơn.
Yêu cầu là xét 1 dòng với tất cả các dòng còn lại (từng dòng 1).
Điều kiện là, xét lần lượt từng cặp cột kế nhau (2 dòng là 4 ô), hễ có ít nhất 1 ô có dữ liệu thì đạt.
Nếu 2 cột (1, 2) không thoả thì phải xét tiếp cặp cột kế (3, 4), cho đến hết (199, 200) gì đó.
Như vậy ta phân tích ngược thế nào là không thoả, sẽ có 2 loại không thoả đk:
1. Dòng trống (tác giả khẳng định không có dòng trống)
2. Dòng có dữ liệu xen kẽ 2 cột một: Thí dụ 1 dòng có dữ liệu toàn ô xanh, 1 dòng có dữ liệu toàn ô đỏ. (theo cách tô màu file gốc: 2 cột xanh, 2 cột đỏ, rồi 2 cột xanh ... đến hết)
Yêu cầu là xét 1 dòng với tất cả các dòng còn lại (từng dòng 1).
Điều kiện là, xét lần lượt từng cặp cột kế nhau (2 dòng là 4 ô), hễ có ít nhất 1 ô có dữ liệu thì đạt.
Nếu 2 cột (1, 2) không thoả thì phải xét tiếp cặp cột kế (3, 4), cho đến hết (199, 200) gì đó.
Như vậy ta phân tích ngược thế nào là không thoả, sẽ có 2 loại không thoả đk:
1. Dòng trống (tác giả khẳng định không có dòng trống)
2. Dòng có dữ liệu xen kẽ 2 cột một: Thí dụ 1 dòng có dữ liệu toàn ô xanh, 1 dòng có dữ liệu toàn ô đỏ. (theo cách tô màu file gốc: 2 cột xanh, 2 cột đỏ, rồi 2 cột xanh ... đến hết)
1/ Dòng trống: Theo data thí khá nhiều cụ thể dòng có số 17, 18 ...
2/ Cái vụ 2 ô liên tiếp (xanh, đỏ) này hơi khó hiểu. Nếu toàn ô đỏ không có dữ liệu hay ô xanh không có dữ liệu thì thỏa hay không thỏa hay chỉ duy nhất 1 cặp ô (xanh hay đỏ) kg có dữ liệu là thoả (thoát).
1. Tác giả nói dữ liệu thực không trống
2. Dòng (A) toàn ô đỏ không có dữ liệu, thì vẫn xét, gặp dòng (B) toàn ô xanh không có dữ liệu, mới loại bỏ. Gặp dòng (C) có dữ liệu vừa xanh vừa đỏ cũng có cơ may!
1. Tác giả nói dữ liệu thực không trống
2. Dòng (A) toàn ô đỏ không có dữ liệu, thì vẫn xét, gặp dòng (B) toàn ô xanh không có dữ liệu, mới loại bỏ. Gặp dòng (C) có dữ liệu vừa xanh vừa đỏ cũng có cơ may!
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.
Chươ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.
Khi xét 2 cặp ô liền nhau thì, Nếu chỉ cần có 1 ô có DL là thỏa điều kiện & chép 2 dòng này sang trang tính khác & tiếp tục cuốc hành trình ờ cặp dòng khác sau nó.
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.)
Chươ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.)
Theo em thấy theo data thì của file kèm, file Tim_01
1/ Dòng (không nói gt cột A) 1 thì IU1 có dữ liệu và em đếm chỉ có 79 ô.
2/ Dòng (không nói gt cột A) 8 thì chỉ có F8 và G8 có dữ liệu và đếm là 2.
Vậy dòng 1 (0) và dòng 8 (7) thoả hay không thoả, ie lấy 2 dòng này không.
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.
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!
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.
2/ Bạn định dạng tô màu lại sh 1 và sh 3 cũng như vậy là OK, còn nếu có thể thêm 1 dòng code xóa sh 3 trước khi chạy. Cells.ClearContents
Mọi người chú ý nha. Tôi thấy tác giả có nói một câu như thế này:
Vâng! Cảm ơn rất nhiều GPE đã giúp đỡ! Mình tô màu cho dễ theo dõi thôi ạ! Vấn đề mấu chốt ở đây là tìm ghép 2 dòng dữ liệu sao cho khi ghép trống nhiều nhất không quá 2 cột liên tiếp!
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.
Tôi ví dụ như thế này: _0_1_0_0_0_1 _0_0_0_0_1_0
Nếu điều kiện là sau khi ghé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.
Nếu điều kiện là sau khi ghép bốn ô cùng màu có ít nhất một ô có dữ liệu thì trường hợp này không thỏa điều kiện.
Tác giả cần xem lại xem yêu cầu của mình chính xác là như thế nào.
Mọi người chú ý nha. Tôi thấy tác giả có nói một câu như thế này:
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.
Tôi ví dụ như thế này: _0_1_0_0_0_1 _0_0_0_0_1_0
Nếu điều kiện là sau khi ghé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.
Nếu điều kiện là sau khi ghép bốn ô cùng màu có ít nhất một ô có dữ liệu thì trường hợp này không thỏa điều kiện.
Tác giả cần xem lại xem yêu cầu của mình chính xác là như thế nào.
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!
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.
2/ Bạn định dạng tô màu lại sh 1 và sh 3 cũng như vậy là OK, còn nếu có thể thêm 1 dòng code xóa sh 3 trước khi chạy. Cells.ClearContents
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!
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!
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.
Có phải điều kiện là
1/ Cột B có dữ liệu thì thoát. Chỉ xét cột B rỗng.
Hay là
2/ Các 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
Chạy thử code hình như không thấy hàng nào có. Và lưu ý có khả năng ArrKQ có số dòng > 65000 vì có thể thoả hết => số dòng quá lớn.
PHP:
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 Sub
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.
Có phải điều kiện là
1/ Cột B có dữ liệu thì thoát. Chỉ xét cột B rỗng.
Hay là
2/ Các 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
Chạy thử code hình như không thấy hàng nào có. Và lưu ý có khả năng ArrKQ có số dòng > 65000 vì có thể thoả hết => số dòng quá lớn.
PHP:
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 Sub
Vâ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!
Mình xin nói lại Điều kiện là khi ghép cặp thoả mãn: cột B không có dữ liệu và trong tất cả các nhóm gồm 2 cột liên tiếp (C;D), (E;F),...,(IU;IV) phải đều có dữ liệu thì mới chép. Còn nếu cột B có dữ liệu hoặc có 1 nhóm bất kì nào đó không có dữ liệu thì bỏ qua!
Xin cảm ơn bạn rất nhiều lần!
Vâ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!
Mình xin nói lại Điều kiện là khi ghép cặp thoả mãn: cột B không có dữ liệu và trong tất cả các nhóm gồm 2 cột liên tiếp (C;D), (E;F),...,(IU;IV) phải đều có dữ liệu thì mới chép. Còn nếu cột B có dữ liệu hoặc có 1 nhóm bất kì nào đó không có dữ liệu thì bỏ qua!
Xin cảm ơn bạn rất nhiều lần!
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:
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 Sub
(1) Dùng chuột bôi chọn toàn bộ câu lệnh & bấm fím 'Delete'; Cách này tuy tiện nhưng không fải hay nhất;
(2) Chỉ cần bấm thêm dấu nháy đơn lên đầu dòng lệnh ("'"); Nếu có nhã í làm đẹp cả sau này, cuối dong ta cũng nhập thêm 1 nháy đơn cho có trước có sau, nghĩa tình;
(2) Thay vì dấu nháy đơn như trên, ta dài dòng 1 chút: nhập chữ 'rem' đầu dòng; Nếu sau đó bấm chuột ở hàng khác, cái từ ta nhập nó chuyển thành 'Rem' là nó đồng í ở với ta rồi!
Chúc mọi người vui vẻ cuới tuần vô cùng thoải mái!
(1) Dùng chuột bôi chọn toàn bộ câu lệnh & bấm fím 'Delete'; Cách này tuy tiện nhưng không fải hay nhất;
(2) Chỉ cần bấm thêm dấu nháy đơn lên đầu dòng lệnh ("'"); Nếu có nhã í làm đẹp cả sau này, cuối dong ta cũng nhập thêm 1 nháy đơn cho có trước có sau, nghĩa tình;
(2) Thay vì dấu nháy đơn như trên, ta dài dòng 1 chút: nhập chữ 'rem' đầu dòng; Nếu sau đó bấm chuột ở hàng khác, cái từ ta nhập nó chuyển thành 'Rem' là nó đồng í ở với ta rồi!
Chúc mọi người vui vẻ cuới tuần vô cùng thoải má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':
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
Rem 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 Sub
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!
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!
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).
PHP:
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.
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).
PHP:
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
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.
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!
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).
PHP:
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ẻ!
