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

Liên hệ QC
(Marco của BoyXin+ tốc độ chạy cực nhanh, test trên máy của tôi có thời gian = 0)
Hàm kiểm tra 8 số đôi một khác nhau:
Len(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace
("0123456789", t, ""), w, ""), e, ""), n, ""), y, ""), i, ""), g, ""), h, "")) = 2
 
Các bạn giải giúp bài thứ 12, như sau

Tôi có một số ngẫu nhiên gồm 6 chữ số, ví dụ 109872
Viết giúp tôi macro để xác định số lớn nhất có thể từ các ký số trên
Đáp án macro sẽ là 987210
Xin cảm ơn các bạn đã & đang quan tâm!

Mã: 
 [/COLOR]
[COLOR=white] Randomize
 Tong = 999999 - Int(8 * Rnd * 10 ^ 5)
[/COLOR]
[COLOR=white]
--=0
 
Lần chỉnh sửa cuối:
Dùng hàm:
Mã: 
Function NumSort(ByVal n) As String
Dim s As String, i As Byte, j As Byte, k As Byte
Dim a(0 To 9) As Byte
    s = ""
    For i = 1 To Len(n)
        k = Mid(n, i, 1) + 0        
        a(k) = a(k) + 1
    Next
    For i = 0 To 9
        If a(i) > 0 Then
            For j = 1 To a(i)
                s = i & s
            Next
        End If
    Next
    NumSort = s
End Function

Nếu thích thì chuyển sang marco nhé!
 
Thật là một tuyệt chiêu lần đầu tiên được thấy về biến mảng.

Mã: 
     a(k) = a(k) + 1
 Rất cảm ơn HoangVuLam về hàm này!
(Để khỏi mang tội spam, xin bịa thêm bài 13, như là dẫn xuất từ bài kế trên:)
Bài 13: Từ các ký số của số có 6 chữ số ngẫu nhiên như trên; Hãy xác lập số nhỏ nhất có thể từ các ký số trên.
Như ví dụ bên trên sẽ là: 102789

Rất cảm ơn các bạn quan tâm!
 
Lần chỉnh sửa cuối:
Sắp thứ tự

Chào bạn!
Cái này:
SA_DQ đã viết:
Mã: 
     a(k) = a(k) + 1
Nhấp chuột vào đây để mở rộng...
là giải thuật cơ bản của kỹ thuật đếm phân phối mà tôi học được từ hồi học Pascal.

Trong hàm NumSort, dòng lệnh: s = i & s
là kỹ thuật nối sau, làm cho chuỗi kết quả sắp thứ tự giảm dần, nếu ta đảo lại thành nối trước: s = s & i
thì nhận được chuỗi sắp tăng dần, chính là yêu cầu ở Bài 13 của Bạn:
SA_DQ đã viết:
Bài 13: Từ các ký số của số có 6 chữ số ngẫu nhiên như trên; Hãy xác lập số nhỏ nhất có thể từ các ký số trên.
Như ví dụ bên trên sẽ là: 102789
Nhấp chuột vào đây để mở rộng...

Thân!
Rất cảm ơn các bạn quan tâm![/quote]
 
Không xử lý con '0' ư bạn?!

Mình nghĩ là phải xử lý thêm chút nữa mới đạt
Ví sẽ là 102789 chứ không phải 012789. Con số sau chỉ mới là con số có 5 chữ số mà thôi!
 
Số nhỏ nhất

SA_DQ đã viết:
Mình nghĩ là phải xử lý thêm chút nữa mới đạt
Ví sẽ là 102789 chứ không phải 012789. Con số sau chỉ mới là con số có 5 chữ số mà thôi!
Nhấp chuột vào đây để mở rộng...
Nếu thế thì đề bài nên viết là:
Bài 13: Từ tập các ký số của số có n chữ số, hãy xác lập số nhỏ nhất có n chữ số tạo thành từ tập các ký số trên.

và có thể điều chỉnh kết quả như sau:

Mã: 
Function NumSortD(ByVal n) As String
Dim s As String, i As Byte, j As Byte, k As Byte
Dim a(0 To 9) As Byte
    n = CStr(n)
    s = ""
    For i = 1 To Len(n)
        k = Mid(n, i, 1) + 0
        a(k) = a(k) + 1
    Next
    For i = 1 To 9
        If a(i) > 0 Then
            For j = 1 To a(i)
                s = s & i
            Next
        End If
    Next
    NumSortD = Left(s, 1) & IIf(a(0) > 0, String(Len(n)-Len(s), "0"), "") & Right(s, Len(s)-1)
End Function
 
Số 220
Tổng các ước số của nó là:
1 + 2 + 4 + 5 + 10 + 11 + 20 + 22 + 44 + 55 + 110 = 284
Với số 284
Sẽ có tổng các ước số là:
1 + 2 + 4 + 71 + 142 = 220
Chúng rất thương nhau, phải không các bạn!

Bài 14: Hãy tìm & ghi lên trang tính các cặp thương nhau của các số có 6 chữ số giúp tôi với. Rất cảm ơn các bạn vì macro sắp tới!

boyxin đã viết:
  1. 220 có tính là ước của 220 không?
  2. 284 có tính là ước của 284 không?
Sao không thấy bác cộng vào nhỉ?
Nhấp chuột vào đây để mở rộng...
Không tính mà! Nếu tính thì chắc chúng không thương nhau rồi!
 
Lần chỉnh sửa cuối:
Xin các bạn góp ý để tăng tốc bài giải 14

Chỉ xét trên 1/5 đoạn đường phải đi nhưng đã mất hơn 3 phút
Rất mong nhận được những ý kiến góp ý để ngỏ hầu tăng tốc

PHP: 
Option Explicit
Sub UocSo220()
 Dim jJ As Long, Ww As Long, Tg2 As Long, Tong As Long
 Dim Rng As Range, sRng As Range
 
 Application.ScreenUpdating = False
 For Ww = 100000 To 126789
    Set Rng = Range("b2:B" & [b65500].End(xlUp).Row)
    Set sRng = Rng.Find(what:=Ww, LookIn:=xlFormulas, lookat:=xlWhole)
    If Not sRng Is Nothing Then GoTo GPE_COM
    For jJ = 2 To Ww
        If Ww Mod jJ = 0 Then _
            Tong = Tong + Ww / jJ
    Next jJ
    For jJ = 2 To Tong
        If Tong Mod jJ = 0 Then _
            Tg2 = Tg2 + Tong / jJ
    Next jJ
    If Tg2 = Ww Then
        With [a65500].End(xlUp)
            .Offset(1) = Ww:        .Offset(1, 1) = Tong
        End With
    Else
        Tong = 0:       Tg2 = 0
    End If
GPE_COM: Next Ww
End Sub
Kết quả:
|A | B |C |
|100 485 | 124 155|
| 122 265 | 139 815 |
|122 368 | 123 152 |
|. . . .|. . . .|
 
SA_DQ đã viết:
Chỉ xét trên 1/5 đoạn đường phải đi nhưng đã mất hơn 3 phút
Rất mong nhận được những ý kiến góp ý để ngỏ hầu tăng tốc

PHP: 
Option Explicit
Sub UocSo220()
 Dim jJ As Long, Ww As Long, Tg2 As Long, Tong As Long
 Dim Rng As Range, sRng As Range
 
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
' * - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '
[f1] = Timer: [a1].CurrentRegion.ClearContents
 For Ww = 2 To 10000
    Set Rng = Range("b2:B" & [b65500].End(xlUp).Row)
    Set sRng = Rng.Find(what:=Ww, LookIn:=xlFormulas, lookat:=xlWhole)
    If Not sRng Is Nothing Then GoTo GPE_COM
    For jJ = 2 To Ww
        If Ww Mod jJ = 0 Then _
            Tong = Tong + Ww / jJ
    Next jJ
    For jJ = 2 To Tong
        If Tong Mod jJ = 0 Then _
            Tg2 = Tg2 + Tong / jJ
    Next jJ
    If Tg2 = Ww Then
        With [a65500].End(xlUp)
            .Offset(1) = Ww:        .Offset(1, 1) = Tong
        End With
    Else
        Tong = 0:       Tg2 = 0
    End If
GPE_COM: Next Ww
[g1] = Timer: [h1] = [g1] - [f1]
' * - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Test thử từ 2 đến 10 000: Total = 9.015625" trong đó có các cặp (7 & 7), (29 & 29), (30 & 71) hình như là không đúng
' * - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '
Em đưa ra giải pháp như sau: Test thử từ 2 đến 10 000: Total = 3.8125"
PHP: 
Sub Bai14()
Dim n As Long, s1 As Long, s2 As Long, i As Long, j As Long
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
' * - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '
[f1] = Timer: [a1].CurrentRegion.ClearContents
For n = 2 To 10000
Set clls = Range([b2], [b2].End(xlDown)).Find(what:=n)
If Not clls Is Nothing Then
    With [a65535].End(xlUp)
        .Offset(1) = n: .Offset(1, 1) = clls.Offset(, -1).Value
    End With
Else
    s1 = 1: s2 = 1: s11 = "1": s21 = "1"
    If SoNT(n) = False Then
        For i = 2 To n / Uoc_NN(n)
            If n Mod i = 0 Then s1 = s1 + i
        Next
        If SoNT(s1) = False Then
            For j = 2 To s1 / Uoc_NN(s1)
                If s1 Mod j = 0 Then s2 = s2 + j
            Next
            If n = s2 Then
                With [a65535].End(xlUp)
                    .Offset(1) = n: .Offset(1, 1) = s1
                End With
            End If
        End If
    End If
End If
Next
[g1] = Timer: [h1] = [g1] - [f1]
' * - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub
Function SoNT(So As Long) As Boolean
Dim n As Long
    If So < 2 Or (So <> 2 And So Mod 2 = 0) Or So <> Int(So) Then Exit Function
    If So = 3 Or So = 2 Then SoNT = True: Exit Function
    Select Case So Mod 6
         Case 1, 5
         For n = 5 To Sqr(So) Step 6
             If So Mod n = 0 Or So Mod n + 2 = 0 Then Exit Function
         Next n
    Case Else
        Exit Function
    End Select
    SoNT = True
End Function
Function Uoc_NN(So As Long) As Long
Dim n As Long
    For n = 2 To So
        If So Mod n = 0 Then Exit For
    Next
Uoc_NN = n
End Function
Các bác kiểm tra giúp xem còn sai sót gì không?
 
Chỉnh sửa lần cuối bởi điều hành viên:
Một cách khác để tìm số nguyên tố

BoyXin xem thử có thể sửa & kiểm lại tốc độ tìm số nguyên tố theo định nghĩa sau:
Nếu GPE là số nguyên tố lớn hơn 3, thì GPE^2 - 1 là bội số của 24
Chứng minh:
Một số nguyên tố lúc nào cũng có dạng:
SNT = bội số của 4 (+/-) 1 = Bội số của 6 (+/-) 1
SNT = ( Bội số của 4 cộng trừ 1) = ( Bội số của 6 cộng trừ 1)
Mà GPE^2 - 1 = (GPE -1) (GPE + 1) => GPE = bội số của 24;
 
Bài này tôi tính chỉ có 27 cặp số - Không biết có sai gì không, các bạn kiểm tra giúp:
Mã: 
' Hàm tính tổng các ước '
Private Function uSum(So As Long) As Long
Dim s As Long, i As Long
    s = 1
    For i = 2 To Int(Sqr(So))
        If (So Mod i = 0) Then s = s + i + IIf(i ^ 2 <> So, So \ i, 0)
    Next
    uSum = s
End Function

' ========================== '
' Liệt kê các cặp số 6 chữ số (a, b), '
' sao cho tổng các ước của a (không kể chính nó) là b và ngược lại '
' ========================== '
 
Sub Bai_14() 
Dim c As Long, r As Long, r0 As Long, ks As Long, sk As Long, x As Long
Dim a, Rng As Range
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    [D1] = Timer
    Set Rng = [A1:B100] ' dieu chinh sau khi da test
    Rng.ClearContents
    r0 = 0
    For r = 100000 To 999999
        ks = uSum(r)
        If Len(ks & "") = 6 Then
            sk = uSum(ks)
            If (sk = r) Then
                If WorksheetFunction.CountIf(Rng, r) = 0 Then
                    r0 = r0 + 1
                    Cells(r0, 1) = r
                    Cells(r0, 2) = ks
                End If
            End If
        End If
    Next r
    [E1] = Timer: [F1] = [E1] - [D1]
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub
 
boyxin đã viết:
Test thử từ 2 đến 10 000: Total = 9.015625" trong đó có các cặp (7 & 7), (29 & 29), (30 & 71) hình như là không đúng
' * - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '
Em đưa ra giải pháp như sau: Test thử từ 2 đến 10 000: Total = 3.8125"
. . . . .
Các bác kiểm tra giúp xem còn sai sót gì không?
Nhấp chuột vào đây để mở rộng...

Kết quả trên máy của mình về thời gian: 1.548875
Nhưng vẫn còn những điều chưa hết ý cho lắm; Như sau:

* Kết quả:
| A | B |C |
| 6 | 6 | |
| 28 | 28 | |
| 220 | 284 | |
| 284 | 220 | |
| 496 | 496 | |
| 1184 | 1210 |<-Tr |
| 1210 | 1184|<-Tr |
| 2620 | 2924 | ! |
| 2924 | 2620 |! |
| 5020 | 5564 |& |
| 5564 | 5020 |& |
| 6232 | 6368 |T |
| 6368 | 6232 |T |
| 8128 | 8128 |!!! |
*./ Nhìn bảng trên, ta thấy không thể chấp nhận các kết quả tô màu đỏ;
*./ Hơn nữa, chúng ta có thể giảm thời gian khi loại những đáp án trùng (tô màu tím hay có đánh dấu tại cột 'C'
 
Lần chỉnh sửa cuối:
Cũng chỉ mong bạn & tôi, chúng ta càng ngày càng hoàn thiện hơn mà thôi!

ChanhTQ@ đã viết:
Kết quả trên máy của mình về thời gian: 1.548875
Nhưng vẫn còn những điều chưa hết ý cho lắm; Như sau:

* Kết quả:
| A | B |C |
| 6 | 6 | |
| 28 | 28 | |
| 220 | 284 | |
| 284 | 220 | |
| 496 | 496 | |
| 1184 | 1210 |<-Tr |
| 1210 | 1184|<-Tr |
| 2620 | 2924 | ! |
| 2924 | 2620 |! |
| 5020 | 5564 |& |
| 5564 | 5020 |& |
| 6232 | 6368 |T |
| 6368 | 6232 |T |
| 8128 | 8128 |!!! |
*./ Nhìn bảng trên, ta thấy không thể chấp nhận các kết quả tô màu đỏ;
*./ Hơn nữa, chúng ta có thể giảm thời gian khi loại những đáp án trùng (tô màu tím hay có đánh dấu tại cột 'C'
Nhấp chuột vào đây để mở rộng...

Hic, cái đáng quan tâm ở đây là xử lý tốc độ, giảm thời gian code làm việc

  1. Còn mấy cái liệt kê đó thì có thể thay đổi đơn giản
  2. Việc chấp nhận hay không chấp nhận là do quan điểm (có thể làm 1 test: chấp nhận 28 và 28 là 1 cặp số; phản đối khảng định trên)
Theo boyxin thuật toán tính tổng các ước như hoangvuluan đã làm
PHP: 
Function uSum(So As Long) As Long
' Hàm tính tổng các ước '
Dim s As Long, i As Long
    s = 1
    For i = 2 To Int(Sqr(So))
        If (So Mod i = 0) Then s = s + i + IIf(i ^ 2 <> So, So \ i, 0)
    Next
    uSum = s
End Function
đã rút ngắn thời gian đáng kể

Vấn đề đặt ra là liệu có thể thay đổi để rút ngắn thời gian được nữa không? Mong các Bác quan tâm
 
Bài số 15 đây:

Đề bài 15:
PHP: 
 ABCDE
-------- = 9           '(Hay là abcde/fghij =9)'
 FGHIJ
 
Tìm các số mà các chữ cái đang làm đại diện cho chúng.
Hãy tìm các đáp án bằng một macro giúp tôi nha; Xin cảm ơn các bạn.
 
ChanhTQ@ đã viết:
Đề bài 15:
PHP: 
 ABCDE
-------- = 9           '(Hay là abcde/fghij =9)'
 FGHIJ
 
Tìm các số mà các chữ cái đang làm đại diện cho chúng.
Hãy tìm các đáp án bằng một macro giúp tôi nha; Xin cảm ơn các bạn.
Nhấp chuột vào đây để mở rộng...
Bài này không có kết quả thỏa mãn điều kiện đâu. cả 2 số đều là 4 chữ số và không có các con số trùng nhau trong cả 2 số. Xét cái số ở mẫu số sẽ thấy số nhỏ nhất có thể thỏa mãn điều kiện đầu bài(4 chữ số khác nhau) là số 1234. Đem số này nhân với 9 sẽ có kết quả là 1234x9=11106 là 1 số có 5 chữ số, vậy nếu các số khác lớn hơn thì đương nhiên là cũng là số có 5 chữ số, vậy sao mà thỏa mãn được điều kiện đầu bài.
(Xin lỗi là đọc nhầm thành 4 chữ số, ở đây là 5 chữ số, nhưng kết quả cũng tương tự, không có kết quả thỏa mãn được)

boyxin đã viết:
Làm mò ra đáp số:
10638 * 9 = 95742
10647 * 9 = 95823

..........
Nhấp chuột vào đây để mở rộng...
Ồ, Xin lỗi vì đã suy luận nhầm, thiếu mất số 0.
 
Chỉnh sửa lần cuối bởi điều hành viên:

Làm mò ra đáp số:
10638 * 9 = 95742
10647 * 9 = 95823

..........​
 
Chỉnh sửa lần cuối bởi điều hành viên:
Chỉnh sửa lần cuối bởi điều hành viên:
ChanhTQ@ đã viết:
Còn 1 đáp án nữa BoyXin à!
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub Bai15()
Dim sbc As Long, sc As Long
Dim a As Byte, b As Byte, c As Byte, d As Byte, e As Byte
Dim f As Byte, g As Byte, h As Byte, i As Byte, j As Byte
For sc = 10234 To 11111
    sbc = sc * 9
    f = 1: g = (sc \ 1000) Mod 10: h = (sc \ 100) Mod 10: i = (sc \ 10) Mod 10: j = sc Mod 10
    a = 9: b = (sbc \ 1000) Mod 10: c = (sbc \ 100) Mod 10: d = (sbc \ 10) Mod 10: e = sbc Mod 10
    If (b <> 1) * (b <> 9) * (b <> c) * (b <> d) * (b <> e) * (b <> g) * (b <> h) * (b <> i) * (b <> j) * _
        (c <> 1) * (c <> 9) * (c <> d) * (c <> e) * (c <> g) * (c <> h) * (c <> i) * (c <> j) * _
        (d <> 1) * (d <> 9) * (d <> e) * (d <> g) * (d <> h) * (d <> i) * (d <> j) * _
        (e <> 1) * (e <> 9) * (e <> g) * (e <> h) * (e <> i) * (e <> j) * _
        (g <> 1) * (g <> 9) * (g <> h) * (g <> i) * (g <> j) * _
        (h <> 1) * (h <> 9) * (h <> i) * (h <> j) * _
        (i <> 1) * (i <> 9) * (i <> j) * _
        (j <> 1) * (j <> 9) Then
    [a65535].End(xlUp).Offset(1).Value = sbc
    [b65535].End(xlUp).Offset(1).Value = sc
    End If
Next
End Sub


Kết quả:
  1. 10638 * 9 = 95742
  2. 10647 * 9 = 95823
  3. 10836 * 9 = 97524
---------------------------
ChanhTQ@ đã viết:
Có chung tính chất : Các số ở mẫu số (cũng như các số ở tử số), đều chia hết cho 9
PHP: 
[center] :-= +-+-+-+ -=.,, :=\+ @$@!^%[/center]
Nhấp chuột vào đây để mở rộng...
Nếu cho biết tính chất mẫu chia hết cho 9 thì thay
PHP: 
For sc = 10234 To 11111
thành
PHP: 
For sc = 10233 To 11111 Step 9
sẽ giảm chút về số vòng lặp, cải thiện thêm chút về thời gian
 
Lần chỉnh sửa cuối:
ChanhTQ@ đã viết:
Đề bài 15:
PHP: 
 ABCDE
-------- = 9           '(Hay là abcde/fghij =9)'
 FGHIJ
 
Tìm các số mà các chữ cái đang làm đại diện cho chúng.
Hãy tìm các đáp án bằng một macro giúp tôi nha; Xin cảm ơn các bạn.
Nhấp chuột vào đây để mở rộng...

- Không số nào lặp lại
- ABCDE chia hết cho 9 --> A+B+C+D chia hết cho 9
- Vì Mẫu số > Tử số :
- Nếu F = 0 --> F = . . . .
- Nếu F # 0 : F*9 = A --> F = 1; A = 9
​
Mới nghĩ được đến đấy. Hu hu hu

--CV--
 
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

S
Công thức để hightlight
Trả lời
5
Đọc
158
tle2003
T
yeudoi
Google Sheets update gấp đôi số cell trong bảng tính
    • Thích
    • Yêu thích
Trả lời
8
Đọc
5K
maikhoamt
maikhoamt
son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
7
Đọc
145
hoangtuaotrang_hp_vn
H
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
3 4 5
Trả lời
81
Đọc
1K
ptm0412
ptm0412
xuongrongdat
Cần giúp: Tùy chỉnh đậm nhạt khung viền ô con trỏ hiện hành
2
Trả lời
27
Đọc
2K
robokk8
robokk8
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