Liệt kê toàn bộ các số điện thoại đẹp lên trang tính.

Liên hệ QC
Từ Code của thầy Long, xin chuyển đổi 1 tẹo cho dễ nhìn

PHP:
Option Explicit
Dim Rw As Long, N1 As Byte, jJ As Byte, N2 As Byte, N3 As Byte
Dim N4 As Byte, N5 As Byte, N6 As Byte, N7 As Byte
Dim Timer_ As Double
Sub Bai04()
 Application.ScreenUpdating = False
 Timer_ = Timer:                Rw = 1
 For jJ = 3 To 5
    If jJ = 4 Then jJ = 5
    For N6 = 0 To 9
        For N5 = 0 To 9
            For N4 = 0 To 9
                For N3 = 0 To 9
                    For N2 = 0 To 9
                        For N1 = 0 To 9
    If N6 <> jJ And N6 <> N5 And N6 <> N4 And N6 <> N3 And N6 <> N2 And N6 <> N1 Then
        If N5 <> jJ And N5 <> N4 And N5 <> N3 And N5 <> N2 And N5 <> N1 Then
            If N4 <> jJ And N4 <> N3 And N4 <> N2 And N4 <> N1 Then
                If N3 <> jJ And N3 <> N2 And N3 <> N1 Then
                    If N2 <> jJ And N2 <> N1 Then
                        If N1 <> jJ Then
                            Cells(Rw, jJ) = jJ & N6 & N5 & N4 & N3 & N2 & N1
        Rw = Rw + 1:
        If Rw > 60480 Then Rw = 1
 
     End If:    End If:    End If:    End If:    End If:    End If
 Next N1, N2, N3, N4, N5, N6, jJ
 Cells(3, "A") = Timer - Timer_
End Sub
Nếu ta lấy hiệu giữa hai cột '5' & '3' tương ứng sau khi chạy macro, thì dường như hiệu này có quy luật;
Nếu ta tìm ra quy luật này thì cơ may giảm 30% thời gian là có thể!?
 
Nếu ta lấy hiệu giữa hai cột '5' & '3' tương ứng sau khi chạy macro, thì dường như hiệu này có quy luật;
Nếu ta tìm ra quy luật này thì cơ may giảm 30% thời gian là có thể!?
Em vẫn theo trường phái replace, thấy có vẻ nhanh hơn code của Thầy Long và của Bác
Code 1 sẽ tìm từ 123456 - >987654 và thấy 3 hoặc 5 =0
Code 2 tìm từ 12345 - >987654. Em thấy code 1 nhanh hơn, do giảm giới hạn for.
làm xong thay toàn bộ 3 = 5 bằng replace.
Code 1
PHP:
Option Explicit
Dim iStr As String, iStrg As String
Dim k As Long, i As Long, j As Long
Dim Tg As Double, MyRng As Range, iCll As Range
Sub vidu()
Application.ScreenUpdating = False
Sheet3.Select
Tg = Timer
[a1:a65000].ClearContents
k = 0
For i = 123456 To 987654
    iStr = CStr(i)
    If InStr(iStr, 0) > 0 Then GoTo next_j
        For j = 5 To 1 Step -1
            iStrg = Replace(iStr, Mid(iStr, j, 1), "")
            If Len(Trim(iStrg)) < j Then
                GoTo next_j
            End If
            iStr = iStrg
            If Len(Trim(iStrg)) = 1 Then
                k = k + 1
                If Left(CStr(i), 1) <> 3 Then
                    Cells(k, 1) = "3" & CStr(i)
                Else
                    Cells(k, 1) = "3" & Right("0" & Replace(CStr(i), 3, 0), 6)
                End If
            End If
        Next
next_j:
Next
Columns("B:B").Value = Columns("A:A").Value
Set MyRng = Columns("B:B")
With MyRng
    .Replace What:=3, Replacement:=5, LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End With
[C1] = Timer - Tg
Application.ScreenUpdating = True
End Sub
Code 2
PHP:
Sub LietKe()
Application.ScreenUpdating = False
Sheet2.Select
Tg = Timer
k = 1
Columns("A:B").ClearContents
For i = 12456 To 987654
    iStr = Right("0" & i, 6)
    If InStr(iStr, 3) > 0 Then GoTo next_j
        For j = 5 To 1 Step -1
            iStrg = Replace(iStr, Mid(iStr, j, 1), "")
            If Len(Trim(iStrg)) < j Then
                GoTo next_j
            End If
            iStr = iStrg
            If Len(Trim(iStrg)) = 1 Then
                Cells(k, 1) = "3" & Right("0" & i, 6)
                k = k + 1
            End If
        Next
next_j:
Next

Columns("B:B").Value = Columns("A:A").Value
Set MyRng = Columns("B:B")
With MyRng
    .Replace What:=3, Replacement:=5, LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End With
[C1] = Timer - Tg
Application.ScreenUpdating = True
End Sub
Em thay thuật giải X1<>X2<>...X6 bằng len.
Chắc máy Bác PTM mạnh lắm thế nào, Bác Mỹ up code để em kiểm chứng với. Theo Code Thầy Long và Bác Chanh em thấy # 30"
 
Em vẫn theo trường phái replace, thấy có vẻ nhanh hơn code của Thầy Long và của Bác
Em thay thuật giải X1<>X2<>...X6 bằng len.
Chắc máy Bác PTM mạnh lắm thế nào, Bác Mỹ up code để em kiểm chứng với. Theo Code Thầy Long và Bác Chanh em thấy # 30"
Đúng là máy của PTM rất mạnh, nên mình nhờ thử đó chớ!
Macro của ThuNghi giảm so với của thấy Long ( & . . .), giờ chỉ còn 2/3 thời gian!
 
Tức quá nên phải nói! Hôm qua giờ ngứa ngáy chân tay quá, mà bị cấm tham gia!
Test lại:
Code Thầy Long: 7,28125''
Code nhà chủ Chanh@: 6.859375"
Code Thunghi (Code1): 11,46875"
Code Thu nghi (code2): 12,984375"

Code Ptm: 4,09375"

Để công bằng, mọi code mình đều thêm vào:
PHP:
With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
.................

        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
End With


nhưng vì không được phép chủ nhà nên không post lên!
 
Lần chỉnh sửa cuối:
To ThuNghi:
Code 1 Sub Vidu và Code 2 Sub Lietke còn bị lỗi ở các số đầu là 5 (có nhiều số có 2 số 5).
|
A​
|
B​
|
C​
|
1​
|
3012456​
|
5012456​
|
x​
|
2​
|
3.012.457​
|
5.012.457​
|x|
3​
|
3.012.458​
|
5.012.458​
|x|
4​
|
3.012.459​
|
5.012.459​
|x|
5​
|
3.012.465​
|
5.012.465​
|x|
6​
|
3.012.467​
|
5.012.467​
| |
7​
|
3.012.468​
|
5.012.468​
| |
8​
|
3.012.469​
|
5.012.469​
| |
9​
|
3.012.475​
|
5.012.475​
|x|
10​
|
3.012.476​
|
5.012.476​
| |
11​
|
3.012.478​
|
5.012.478​
| |
12​
|
3.012.479​
|
5.012.479​
| |
13​
|
3.012.485​
|
5.012.485​
|x|
14​
|
3.012.486​
|
5.012.486​
| |
15​
|
3.012.487​
|
5.012.487​
| |
16​
|
3.012.489​
|
5.012.489​
| |
17​
|
3.012.495​
|
5.012.495​
|x|
Cột C đánh dấu x các số trên cột B bị trùng 2 số 5
 
Lỗi code Thu Nghi ở chỗ này:
Mã:
    .Replace [B]What:=3[/B], [B]Replacement:=5[/B], ...
Thay được số 3 đầu thành 5, chưa thay số 5 trong dãy 6 số sau thành 3.

Ptm cũng dùng replace nhưng dùng công thức:
Range("B1:B60480").FormulaR1C1 = "=5000000+VALUE(SUBSTITUTE(RIGHT(RC[-1],6),5,3))"

Sau đó thay công thức bằng giá trị:
Range("B1:B60480") = Range("B1:B60480").Value

Cả 2 dòng lệnh này chỉ mất 0,56" cộng với code chính 3,58"

Đỡ ngứa rồi!
 
Thú thật em cũng chả biết tại sao, chuyện số 3 or 5 thì dễ rồi. Còn cái Timer máy em chạy thế nào. Em có sửa lại code 1 chút, các Bác test hộ. Em test cũng # 30".
Nhờ các Bác hướng dẫn, em thấy về logich khá OK mà không biết lủng củng chỗ nào.
PHP:
Option Explicit
Dim iStr As String, iStrg As String
Dim k As Long, i As Long, j As Long
Dim Tg As Double
Sub LietKe04()
Application.ScreenUpdating = False
Sheet3.Select
Tg = Timer
[A1:B61000].Clear
k = 0
For i = 123456 To 987654
  iStr = CStr(i)
  If InStr(iStr, 0) > 0 Then GoTo next_j
    For j = 5 To 1 Step -1
        iStrg = Replace(iStr, Mid(iStr, j, 1), "")
        If Len(Trim(iStrg)) < j Then
            GoTo next_j
        End If
        iStr = iStrg
        If Len(iStrg) = 1 Then
          k = k + 1
          Cells(k, 1) = 3 & Replace((i), 3, 0)
          Cells(k, 2) = 5 & Replace((i), 5, 0)
        End If
    Next
next_j:
Next
[C1] = Timer - Tg
Application.ScreenUpdating = True
End Sub
 
Thú thật em cũng chả biết tại sao, chuyện số 3 or 5 thì dễ rồi. Còn cái Timer máy em chạy thế nào. Em có sửa lại code 1 chút, các Bác test hộ. Em test cũng # 30".
Nhờ các Bác hướng dẫn, em thấy về logich khá OK mà không biết lủng củng chỗ nào.

attachment.php
attachment.php

Test code của bác ThuNghi __________________________ Test code của bác ChanhTQ@​
 

File đính kèm

  • Test TN.JPG
    Test TN.JPG
    20.4 KB · Đọc: 78
  • Test Chanh.JPG
    Test Chanh.JPG
    24.7 KB · Đọc: 81
Lần chỉnh sửa cuối:
12,28125", không quan trọng cái timer, timer là như nhau, tốc độ máy mới tạo khác biệt, vì vậy khi test code thì so với version trước đó cũng trên 1 máy, chứ đừng so với máy khác.

Với lại, test khi mới khởi động thì khác, khi chạy 1 vài tiếng rồi thì cũng khác, hoặc khi đang mở nhiều chương trình đồng thời cũng bị chậm lại.

Cho nên, close any application that are running!
Sẵn dịp, nhờ Boyxin test dùm code này trên máy Boyxin, thanks. Mình test máy mình là 4,09375" => 4,14258"
PHP:
Sub Lietke()
Range("o2") = Timer
Range("A1:m61000").NumberFormat = "0 000 000"
With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        Rowi = 0
        Colj = 0
        Dk = True
So1 = 3
For So2 = 0 To 9
    Dk = So2 <> So1
    If Dk Then
        For So3 = 0 To 9
        Dk = So3 <> So1 And So3 <> So2
        If Dk Then
            For So4 = 0 To 9
                Dk = So4 <> So1 And So4 <> So2 And So4 <> So3
                If Dk Then
                For So5 = 0 To 9
                    Dk = So5 <> So1 And So5 <> So2 And So5 <> So3 And So5 <> So4
                    If Dk Then
                    For So6 = 0 To 9
                        Dk = So6 <> So1 And So6 <> So2 And So6 <> So3 And So6 <> So4 And So6 <> So5
                        If Dk Then
                        For So7 = 0 To 9
                            Dk = So7 <> So1 And So7 <> So2 And So7 <> So3 And So7 <> So4 And So7 <> So5 And So7 <> So6
                            If Dk Then
                                Rowi = IIf(Rowi + 1 = 60481, 1, Rowi + 1)
                                Colj = Colj + IIf(Rowi = 1, 1, 0)
                                Cells(Rowi, Colj) = So1 & So2 & So3 & So4 & So5 & So6 & So7
                            End If
                        Next So7
                    End If
                Next So6
                End If
            Next So5
            End If
        Next So4
        End If
    Next So3
    End If
Next So2
    Range("B1:B60480").FormulaR1C1 = "=5000000+VALUE(SUBSTITUTE(RIGHT(RC[-1],6),5,3))"
    Range("B1:B60480") = Range("B1:B60480").Value
    Range("o3") = Timer
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub
 
Lần chỉnh sửa cuối:
12,28125", không quan trọng cái timer, timer là như nhau, tốc độ máy mới tạo khác biệt, vì vậy khi test code thì so với version trước đó cũng trên 1 máy, chứ đừng so với máy khác.

Với lại, test khi mới khởi động thì khác, khi chạy 1 vài tiếng rồi thì cũng khác, hoặc khi đang mở nhiều chương trình đồng thời cũng bị chậm lại.

Cho nên, close any application that are running!
Sẵn dịp, nhờ Boyxin test dùm code này trên máy Boyxin, thanks. Mình test máy mình là 4,09375" => 4,14258"

attachment.php

Test code của bác Ptm

Còn đây là số liệu không làm tròn:
attachment.php

 

File đính kèm

  • Test Ptm.JPG
    Test Ptm.JPG
    20.8 KB · Đọc: 88
  • Test.JPG
    Test.JPG
    68.3 KB · Đọc: 86
Lần chỉnh sửa cuối:
Chúng ta tiếp sang bài 05, xin mời toàn thẻ các bạn xa gần

Trước tiên, xin được phép thay mặt cho toàn thể những người có tác phẩm trong topic này xin cảm ơn các thành viên trong cộng đồng đã lưu tâm đến topic này & làm cho nó sống, động!

Nội dung của bài 05 như sau:
Tìm cho các đại gia các số điện thoại đẹp, thỏa các điều kiện sau đây:
* Tổng các ký số trong nó đem MOD 10 = 9; (Tham khảo bài trước)
* Các ký số sau chỉ có thể bằng hay lớn hơn ký số ngay trước nó.
Ví du: 0000 045, 0000 144, 1234 568, 1244 567, . . . . . . .

PTM bớt zận & thỏa chí tang bồng rồi nha!

Xin mời toàn thể chúng ta tiếp tục, xin rất cảm ơn!
 
Nội dung của bài 05 như sau:
Tìm cho các đại gia các số điện thoại đẹp, thỏa các điều kiện sau đây:
* Tổng các ký số trong nó đem MOD 10 = 9; (Tham khảo bài trước)
* Các ký số sau chỉ có thể bằng hay lớn hơn ký số ngay trước nó.
Ví du: 0000 045, 0000 144, 1234 568, 1244 567, . . . . . . .
Tôi vẫn dùng cách viết của Sub ChuSoKhongTrung vì nó mang tính tổng quát, chỉ cần chỉnh lại theo yêu cầu mới là xong.
Mã:
Sub SoDtTien()
Application.ScreenUpdating = False
Cells.ClearContents
Columns("A:I").NumberFormat = "@"
r = 1
n1 = 3
For n1 = 0 To 9
  r = 1
  For n2 = 0 To 9
    If n2 >= n1 Then
      For n3 = 0 To 9
        If n3 >= n2 Then
          For n4 = 0 To 9
            If n4 >= n3 Then
              For n5 = 0 To 9
                If n5 >= n4 Then
                  For n6 = 0 To 9
                    If n6 >= n5 Then
                      For n7 = 0 To 9
                        If n7 >= n6 Then
                          s17 = n1 + n2 + n3 + n4 + n5 + n6 + n7
                          If s17 Mod 10 = 9 Then
                            Cells(r, n1 + 1) = n1 & n2 & n3 & n4 & n5 & n6 & n7
                            r = r + 1
                          End If
                        End If
                      Next
                    End If
                  Next
                End If
              Next
            End If
          Next
        End If
      Next
    End If
  Next
Next
End Sub
 
Tôi vẫn dùng cách viết của Sub ChuSoKhongTrung vì nó mang tính tổng quát, chỉ cần chỉnh lại theo yêu cầu mới là xong.

Xin phép Thầy Long, boyxin sửa tý teo thế này thì code chạy nhanh hơn chút (được 1144 số)
PHP:
Sub sdt_tien()
Application.ScreenUpdating = False
Cells.ClearContents
[k1] = Timer
Columns("A:I").NumberFormat = "@"
For n1 = 0 To 9
  r = 0
  For n2 = n1 To 9
      For n3 = n2 To 9
          For n4 = n3 To 9
              For n5 = n4 To 9
                  For n6 = n5 To 9
                      For n7 = n6 To 9
                          s17 = n1 + n2 + n3 + n4 + n5 + n6 + n7
                          If s17 Mod 10 = 9 Then
                            r = r + 1
                            Cells(r, n1 + 1) = n1 & n2 & n3 & n4 & n5 & n6 & n7
                          End If
Next: Next: Next: Next: Next:  Next: Next
[k2] = Timer: [k3] = [k2] - [k1]
End Sub
 
Xin phép Thầy Long, boyxin sửa tý teo thế này thì code chạy nhanh hơn chút (được 1144 số)
Rất hay. Nhiều khi tư duy theo lối mòn. Tại sao phải là:
Mã:
For n2=0 to 9
  If n2 >= n1 Then
Mà không là:
Mã:
For n2=n1 to 9
Thanh Boyxin
 
Bài tập 06: "Tìm số điện thoại gánh"
Số có 7 chữ số và đạt các điều kiện sau:
* Chữ số theo thứ tự tính từ bên trái và chữ số theo thứ tự tính từ bên phải giống nhau.
* Chữ số thứ 4 tính từ bên trái phải khác chữ số thứ 3 và thứ 5.
* Số có ít nhất 2 ký tự.
Ví dụ:
1002001, 1110111, 5234325, 9072709
Các số không đạt:
* 000000, 1111111, ... không đạt vì chỉ có duy nhất 1 ký tự.
* 1233321, 0011100, 4077704 không đạt vì chữ số thứ 4 trùng chữ số thứ 3 và thứ 5.
 
Đề xuất thêm tìm số điện thoại gánh:
Số có 7 chữ số và đạt các điều kiện sau:
* Chữ số theo thứ tự tính từ bên trái và chữ số theo thứ tự tính từ bên phải giống nhau.
* Chữ số thứ 4 tính từ bên trái phải khác chữ số thứ 3 và thứ 5.
* Số có ít nhất 2 ký tự.
Ví dụ:
1002001, 1110111, 5234325, 9072709
Các số không đạt:
* 000000, 1111111, ... không đạt vì chỉ có duy nhất 1 ký tự.
* 1233321, 0011100, 4077704 không đạt vì chữ số thứ 4 trùng chữ số thứ 3 và thứ 5.
Làm theo cách truyền thống for i. cái vụ format làm cho chậ hơn thì phải. Các Bác góp ý.
PHP:
Sub SoGanhTN()
Dim i As Long, j As Long, k As Long, iStr As String
Application.ScreenUpdating = False
k = 1
[A1:A65000].ClearContents
[A1:A65000].NumberFormat = "@"
For j = 0 To 9
    For i = 0 To 999
        If j <> Right(i, 1) Then
            iStr = Format(i, "000")
            Cells(k, 1) = iStr & j & Mid(iStr, 3, 1) & Mid(iStr, 2, 1) & Mid(iStr, 1, 1)
            k = k + 1
        End If
    Next
Next
Application.ScreenUpdating = True
End Sub
 
Em nhận thấy 3 số đầu xxx gánh với 3 số cuối yyy

Thì giữa số lập bởi 3 chữ số xxx với số lập bởi 3 chữ số yyy chênh lệch bội của 99 nhưng chưa nghĩ ra cách vận dụng
 
Lần chỉnh sửa cuối:
Nếu loại bỏ đúng theo yêu cầu này
Đề xuất thêm tìm số điện thoại gánh:
Số có 7 chữ số và đạt các điều kiện sau:
* Chữ số theo thứ tự tính từ bên trái và chữ số theo thứ tự tính từ bên phải giống nhau.
* Chữ số thứ 4 tính từ bên trái phải khác chữ số thứ 3 và thứ 5.
* Số có ít nhất 2 ký tự.
Ví dụ:
1002001, 1110111, 5234325, 9072709
Các số không đạt:
* 000000, 1111111, ... không đạt vì chỉ có duy nhất 1 ký tự.
* 1233321, 0011100, 4077704 không đạt vì chữ số thứ 4 trùng chữ số thứ 3 và thứ 5.
Học cách của thầy Long, code này chạy nhanh hơn chút (0.328125") cho ra đủ 9000 số
PHP:
Sub GPE_boyxin()
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    [A1].CurrentRegion.Clear
    [l1] = Timer
For j = 0 To 9
    k = 0
    For s1 = 0 To 9
        For s2 = 0 To 9
            For s3 = 0 To 9
                If s3 <> j Then
                    k = k + 1
                    Cells(k, j + 1) = s1 & s2 & s3 & j & s3 & s2 & s1
                End If
Next: Next: Next: Next
    [A1].CurrentRegion.NumberFormat = "000 0 000"
    [l2] = Timer: [l3] = [l2] - [l1]
    [l4] = [A1].CurrentRegion.SpecialCells(2, 1).Count
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub
 
Lần chỉnh sửa cuối:
9000 như Thu Nghi là đúng chứ? còn phải loại bỏ thêm các số:
* 1233321, 0011100, 4077704 không đạt vì chữ số thứ 4 trùng chữ số thứ 3 và thứ 5

Test trên máy mình:
Code ThuNghi: 1,515625"
Code Boyxin: 0,640625"
Code Ptm: 0,546875"

Cùng thuật toán, nhưng Boyxin liệt kê đủ 1000 ô kể cả ô không đạt lên sheet (blank) nên chậm hơn
Code Thu nghi vẫn chậm hơn vì không có:
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
 
9000 như Thu Nghi là đúng chứ? còn phải loại bỏ thêm các số:


Test trên máy mình:
Code ThuNghi: 1,515625"
Code Boyxin: 0,640625"
Code Ptm: 0,546875"

Cùng thuật toán, nhưng Boyxin liệt kê đủ 1000 ô kể cả ô không đạt lên sheet (blank) nên chậm hơn
Code Thu nghi vẫn chậm hơn vì không có:
.DisplayAlerts = False
.ScreenUpdating = False
.Calculation = xlCalculationManual

Khi em test thì tất cả các code em đều thêm
.DisplayAlerts = ...
.ScreenUpdating = ...
.Calculation = ...
và chạy khoảng 10-15 lần liền, chọn giá trị t/g nhỏ nhất để đảm bảo tính công bằng

Lúc đầu đọc thiếu yêu cầu đề bài nên tường bác ThuNghi liệt kê thiếu. đọc kỹ lại yêu cầu và sửa lại code không hiện ô blank nên nhanh hơn chút, test tại máy của em (0.328125") cho ra đủ 9000 số
 
Web KT
Back
Top Bottom