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

Liên hệ QC
S

sep_hatxel

Thành viên thường trực
Tham gia
24/5/10
Bài viết
217
Được thích
7
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!
 

File đính kèm

  • Copy of TH_NG K_.rar
    484.1 KB · Đọc: 88
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
 
ChanhTQ@ đã viết:
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
Nhấp chuột vào đây để mở rộng...
Mình đã thử maco trên nhưng mình không rõ cơ chế như thế nào? Bạn có thể nói rõ hơn được không? Và kết quả không ra như ý mình muốn?
 
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. . .

Thân ái!
 
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!
 
Vậy bạn nên giả lập lại file khác & đưa lên đ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ố!
 
sep_hatxel đã viết:
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!
Nhấp chuột vào đây để mở rộng...
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é.
 
Bài này có ở đây ( bắt đầu từ #637)

Thú thật chả hiểu yêu cầu bài này thế nào
.
Nhấp chuột vào đây để mở rộng...
http://www.giaiphapexcel.com/forum/...h-các-code-đề-nghị-các-bạn-gửi-vào-đây/page64

Diễn nôm nó thế này ThuNghi à:

Đ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.

--=0 --=0 --=0
 
HYen17 đã viết:
http://www.giaiphapexcel.com/forum/...h-các-code-đề-nghị-các-bạn-gửi-vào-đây/page64

Diễn nôm nó thế này ThuNghi à:

Đ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.

--=0 --=0 --=0
Nhấp chuột vào đây để mở rộng...
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
Để xem có đúng ý tác giả không.
 
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.
Để xem có đúng ý tác giả không.
Nhấp chuột vào đây để mở rộng...
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.

Rất mong ThuNghi tiếp tục!

Thân ái!
/(hà, /(hà,. . . . --=0 --=0 --=0
 
Chỉnh sửa lần cuối bởi điều hành viên:
HYen17 đã viết:
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.

Rất mong ThuNghi tiếp tục!

Thân ái!
/(hà, /(hà,. . . . --=0 --=0 --=0
Nhấp chuột vào đây để mở rộng...
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.
 
Lần chỉnh sửa cuối:
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)
 

File đính kèm

  • GPEtk.rar
    495.4 KB · Đọc: 11
ThuNghi đã viết:
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.
Nhấp chuột vào đây để mở rộng...

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!
 
sep_hatxel đã viết:
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!
Nhấp chuột vào đây để mở rộng...
Bạn trả lời cụ thể tạo sao cột IF: II có 4 ột liên tiếp cùng màu > 2.
Nếu chỉ 2 cột liên tiếp thì cột IT chỉ có 1.
 
ThuNghi đã viết:
Bạn trả lời cụ thể tạo sao cột IF: II có 4 ột liên tiếp cùng màu > 2.
Nếu chỉ 2 cột liên tiếp thì cột IT chỉ có 1.
Nhấp chuột vào đây để mở rộng...
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!
 
SA_DQ đã viết:
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)
Nhấp chuột vào đây để mở rộng...
Cảm ơn sự nhiệt tình giúp đỡ của SA_DQ! Mình đang cho chạy thử maco và xem thời gian hết bao lâu! Một lần nữa cảm ơn bạn!
 
sep_hatxel đã viết:
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!
Nhấp chuột vào đây để mở rộng...
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
 
Hình như bỏ lọt nghiệm đó ThuNghi à!

PHP: 
     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.

Thấn ái!


</span></span>
 
PHP: 
[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
 
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

P
  • Question
Xin code gán mở theo tài khoản/profie đăng nhập bằng gmail sẵn trên trình duyệt
Trả lời
2
Đọc
136
phantu93
P
V
công thức của nó là gì ạ. mong mọi người giúp
Trả lời
1
Đọc
28
CHAOQUAY
C
son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
13
Đọc
273
ongke0711
ongke0711
Salem999999999
Lọc dữ liệu có điều kiện
2
Trả lời
25
Đọc
577
tle2003
T
vuongnlks
Lấy dữ liệu 1 cột cụ thể theo ngày từ nhiều file CSV ứng với mã tương ứng trong cột MA CO PHIEU
Trả lời
1
Đọc
97
BuiQuangThuan
B
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