Liệt kê toàn bộ các số điện thoại đẹp lên trang tính. (1 người xem)

[ChanhTQ@]

Tôi muốn liệt kê toàn bộ các số điện thoại đẹp gồm 7 chữ số. Điều kiện, chỉ liệt kê các số đẹp có số chẵn ở số đầu mà thôi,
Ví dụ: 2000 007, . . . . , 4000 005, . . . . .
Chúng được liệt kê lên từng cột, bắt đầu từ cột 'A'

Xin rất cảm ơn các bạn viết cho macro như vậy.

From PTM0412:
Trước tiên, bạn phải định nghĩa thế nào là số đẹp, giống như bảo người đầu bếp nấu món khoái khẩu của thủ tướng X nước Y, mà không đưa thực đơn vậy.

Số đẹp là (tổng các số trong nó) MOD 10 = 9​

Và như vậy cứ coi như số không cũng là số chẵn luôn giúp nha.


Các bạn giúp mình đi nha, sẽ có hậu tạ!
​

 

[cadafi]

Số đẹp là (tổng các số trong nó) MOD 10 = 9Và như vậy cứ coi như số không cũng là số chẵn luôn giúp nha
Các bạn giúp mình đi nha, sẽ có hậu tạ!

MOD 10 = 9, hay: chia hết cho 9. Bạn đưa một loại ví dụ cụ thể nữa lên xem. Nói như thế cũng còn khó hiểu quá!

 

[ChanhTQ@]

MOD 10 = 9, hay: chia hết cho 9. Bạn đưa một loại ví dụ cụ thể nữa lên xem. Nói như thế cũng còn khó hiểu quá!

[SIZE=3]Ví dụ số điện thoại là  [B]8737 393[/B] Thì[/SIZE]
[SIZE=3]8 + 7 + 3 + 7 + 3 + 9 + 3 = 40 =>    40 MOD 10 = 0[/SIZE]
[SIZE=3]Trường hợp số ĐT là [B]2345 678[/B][/SIZE]
[SIZE=3]2 + 3 + 4 + 5 + 6 + 7 + 8 = 35  =>    35 MOD 10 = 5[/SIZE]
[SIZE=3]Them nữa: Với số [B]6000 003[/B]  =>           9 MOD 10 = 9[/SIZE]

 

[cadafi]

1. Công thức để tính tổng các chữ số trong một dãy số là:

Ô A1 chứa dãy số, ô B1 gõ công thức:
{=SUM(--MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1))}

2. Chon một biến chạy từ 1000000 đến 9999999 và tính tổng các chữ số trong chuỗi đó, nếu MOD 10 của tổng đó = 9 thì lấy riêng ra một sheet.

Cách này hơi lâu.

 

[ChanhTQ@]

Không biết có đúng ý bạn không.

Cách này hơi lâu.

Hầu như cứ 10 số có một số điện thoại gọi là đẹp (theo như định nghĩa của mình);
Vậy cách dùng công thức là không ăn thua đâu, chắc vậy!
9 triệu số thì có khoảng 600.000 số đẹp . Bỏ đi phân nữa hay chỉ lấy 1/3 những số ấy cũng chiếm 6 cột trang tính excel 2003 rồi!
Bỡi lẻ đó mình mới post bài vô đây í mà!

Rất xin cảm ơn các bạn & rất mong chúng ta cùng tiếp tục giúp.

 

[Lệnh Hồ Đại Hiệp]

Hầu như cứ 10 số có một số điện thoại gọi là đẹp (theo như định nghĩa của mình);
Vậy cách dùng công thức là không ăn thua đâu, chắc vậy!
Rất xin cảm ơn các bạn & rất mong chúng ta cùng tiếp tục giúp.

Có hai cách :
1 . Xét số đó, cộng từng số hạng lại với nhau và MOD 10 (Đơn giản, dễ hiểu)
2. Lập ra danh mục tất cả các số có 6 chữ số thỏa mãn điều kiện đó. Khi phát sinh số nào thì chỉ cần kiểm tra xem số đó có nằm trong danh mục đó không (Khổ trước sướng sau)
Chúc vui

 

[ndu96081631]

Không biết có đúng ý bạn không.

Công thức của Salam tại sao không sửa lại thành:

=IF(AND(MOD(A3,9)=0,ISEVEN(LEFT(A3))),A3,"")

Gọn hơn không (đâu cần mãng)

 

[ptm0412]

Chính xác là trong 10 triệu số đầu, có 500.000 số "đẹp".
1. Dùng 1 biến i chạy từ 0 đến 9.999.999, số nào thoả đk thì xuất ra cell: duyệt 10.000.000 số, rất chậm

2. Chia ra 5 khoảng, mỗi khoảng 1.000.000 số với số đầu là 0, 2, 4, 6, 8, vẫn dùng thuật toán duyệt từng số, nhanh hơn 1 chút: từ 1 phút 56 giây đến 2 phút 08 giây (kết quả 500.000 số và chính xác): chỉ duyệt 5.000.000 số, giảm 1 nửa

3. Cũng chia 5 khoảng như trên, dùng thuật toán duyệt nhưng hạn chế vòng lặp, nhanh hơn: từ 1 phút 08 giây đến 1 phút 15 giây, nhưng kết quả kém hơn: chỉ cho 460.557 số. Lý do: chưa thấy được quy luật hiệu số giữa 2 số "đẹp" kế tiếp nhau.
Số lượng số bị duyệt ước khoảng 2.000.000 đến 3.000.000, không thống kê được.

Xem file kèm theo, mỗi sheet có 1 code theo 2 cách.

 

[ChanhTQ@]

Rất biết ơn các bác & các bạn xa gần! Nhất là Lệnh Hồ & PTM0412

Chính xác là trong 10 triệu số đầu, có 500.000 số "đẹp".
1. Dùng 1 biến i chạy từ 0 đến 9.999.999, số nào thoả đk thì xuất ra cell: duyệt 10.000.000 số, rất chậm
2. Chia ra 5 khoảng, . . . . .
3. Số lượng số bị duyệt ước khoảng 2.000.000 đến 3.000.000, không thống kê được.

Mình mới nghĩ ra cách như sau, các bác cho í kiến (đúng/sai):
Duyệt từ 0000009 - 9999999 Step 9; vị chi giảm còn hơn triệu gì đó số lần duyệt;
Nếu kết hợp với cách của bác PTM0412 thì giảm đi 1 nữa?!

Xin các bác phát biểu tiếp tục giúp cho.

Rất cảm ơn sự quan tâm!

 

[ThuNghi]

Mình mới nghĩ ra cách như sau, các bác cho í kiến (đúng/sai):
Duyệt từ 0000009 - 9999999 Step 9; vị chi giảm còn hơn triệu gì đó số lần duyệt;
Nếu kết hợp với cách của bác PTM0412 thì giảm đi 1 nữa?!

Xin các bác phát biểu tiếp tục giúp cho.

Rất cảm ơn sự quan tâm!

Bác ơi, hình như quy luật +9 chỉ tính cho từng 100 số hạng
90+9=99 => mod(9+9,10)=8
Tương tự
180+9=1+8+9=18
199+9=2+0+8=10
Chắc phải tìm theo cách khác. Em thử cho 1 dãy số mà chưa tìm ra quy luật.

 

[boyxin]

List số đẹp (đầu chẵn + 9 nước)

boyxin nghĩ thế này có vẻ nhanh hơn:

b1: chọn ra các số trong khoảng 1-1000000 được 100 000 số, ghi thành 2 cột
b2: thêm 2,4,6,8 vào đầu và cộng hoặc trừ số cuối thích hợp => ta được 400 000 số nữa
vậy tổng cộng có 500 000 số thỏa mãn yêu cầu

(đã test thử trên máy của boyxin: Total = 31 giây List ra được 500 000 số)
​

 

[ThuNghi]

boyxin nghĩ thế này có vẻ nhanh hơn:

b1: chọn ra các số trong khoảng 1-1000000 được 100 000 số, ghi thành 2 cột
b2: thêm 2,4,6,8 vào đầu và cộng hoặc trừ số cuối thích hợp => ta được 400 000 số nữa
vậy tổng cộng có 500 000 số thỏa mãn yêu cầu

Nói chung, về cơ bản ta chỉ cần tìm 6 số hạng mà mod=7, vì số 2 đầu. Còn 4, 6, 8 thì từ kế quả trên ta cộng 2 thôi.
Nhưng mà tìm quy luật: từ 000,000 - 999,999 mà mod(TC,10) = 7 hay 6,5 hay bằng 1 số nào thì chưa biết.

 

[ptm0412]

Mình mới nghĩ ra cách như sau, các bác cho í kiến (đúng/sai):
Duyệt từ 0000009 - 9999999 Step 9; vị chi giảm còn hơn triệu gì đó số lần duyệt;
Nếu kết hợp với cách của bác PTM0412 thì giảm đi 1 nữa?!

Step không phải là 9, mà là 5, 6, 7, 8, 9, 15, 16, 17, 18, 19.
Dựa vào Step và dùng gợi ý trên của bạn Chanh@, rút lại còn 18 giây, đủ 500.000 con, số lần duyệt ước chừng dưới 250.000.

 

[boyxin]

Thật tuyệt vời, thêm tý

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
'----------------------------------------
.............CODE..........................
'----------------------------------------
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

Test tại máy

chỉ mất có 9 giây

 

[ChanhTQ@]

Đúng là thật tuyệt vời, một khi có cộng đồng góp sức.

Coi như chúng ta tạm thời dừng đầu tư thời gian cho bài 01 tại đây. Vì có lẽ phương cách như trên là tối ưu rồi cũng nên.

Xin các bác ra tay với bài thứ hai, như sau:
Với các số có sáu chữ số, ta lại phải liệt kê lên trang tính các số khi mà tổng ba số hàng nghìn bằng tổng ba số hàng đơn vị;
Ví dụ như sau
123123, 123321, 123132, 123312, 123213 & 123231, 123006, 123015. . . .

Xin trân trọng cảm ơn các bác quan tâm!

 

[ptm0412]

Nếu tính luôn số 000 000, dùng 2 vòng lặp:
- 1 vòng ngoài chạy đủ 1.000 vòng, từ 1 đến 999
- 1 vòng trong chạy cũng 1.000 vòng, từ 1 đến 999. Điều kiện là (trong mỗi vòng của vòng For ngoài): tổng 3 số bằng 1 số cho trước.

Đại khái vầy: (06 giây, kể luôn số 0 là 55.252 con)

Sub LietKe()

Range("M5") = Time()
Range("A1:k5500").NumberFormat = "000 000"
With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        Cells(1, 1) = 0
        Rowi = 1
        Colj = 1
        Socong1 = 0
        Socong2 = 0
For i = 1 To 999
    So1 = i
    Sotinh1 = Right("000" & So1, 3)
    Socong1 = Left(Sotinh1, 1) * 1 + Mid(Sotinh1, 2, 1) * 1 + Right(Sotinh1, 1) * 1
    For j = 1 To 999
        So2 = j
        Sotinh2 = Right("000" & So2, 3)
        Socong2 = Left(Sotinh2, 1) * 1 + Mid(Sotinh2, 2, 1) * 1 + Right(Sotinh2, 1) * 1
        If Socong2 = Socong1 Then
            Rowi = IIf(Rowi + 1 = 5501, 1, Rowi + 1)
            Colj = Colj + IIf(Rowi = 1, 1, 0)
            Cells(Rowi, Colj) = So1 * 1000 + So2
        End If
    Next
Next
    Range("M6") = Time()
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[ChanhTQ@]

Theo mình, cần thêm câu lệnh thoát vòng lặp bên trong, lúc cần thiết

Socong1 = Left(Sotinh1, 1) * 1 + Mid(Sotinh1, 2, 1) * 1 + Right(Sotinh1, 1) * 1

[COLOR=#007700]For [/COLOR][COLOR=#0000bb]j [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]1 To 1000 [/COLOR]
[COLOR=#0000bb]      So2 [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]j :                            Sotinh2 [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]Right[/COLOR][COLOR=#007700]([/COLOR][COLOR=#dd0000]"000" [/COLOR][COLOR=#007700]& [/COLOR][COLOR=#0000bb]So2[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000bb]3[/COLOR][COLOR=#007700]) [/COLOR]
[COLOR=#007700]      [SIZE=3][B]If j > SoCong1 Then Exit For[/B][/SIZE]  'Mới thêm'[/COLOR]
[COLOR=#0000bb]Socong2 [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]Left[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]Sotinh2[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000bb]1[/COLOR][COLOR=#007700]) * [/COLOR][COLOR=#0000bb]1 [/COLOR][COLOR=#007700]+ [/COLOR][COLOR=#0000bb]Mid[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]Sotinh2[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000bb]2[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000bb]1[/COLOR][COLOR=#007700]) * [/COLOR][COLOR=#0000bb]1 [/COLOR][COLOR=#007700]+ [/COLOR][COLOR=#0000bb]Right[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]Sotinh2[/COLOR][COLOR=#007700], [/COLOR][COLOR=#0000bb]1[/COLOR][COLOR=#007700]) * [/COLOR][COLOR=#0000bb]1 [/COLOR]
[COLOR=#007700]If [/COLOR][COLOR=#0000bb]Socong2 [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]Socong1 Then [/COLOR]

 

[ptm0412]

If j > SoCong1 Then Exit For  'Mới thêm'

Nếu j > SoCong1 mà thoát, sẽ chỉ liệt kê được 220 em thôi!

Thí dụ:

- Với i = 1, đáng lẽ ta có 3 kết quả: 001 001, 001 010, 001 100, nhưng chỉ tóm được 1 em đầu, bỏ qua 2 em sau, bởi tại bị kể từ j = 2 trở về sau, j > 1
- Với i = 2, đáng lẽ ta có kết quả: 002 002, 002 011, 002 101, 002 110, 002 020, 000 200, nhưng cũng chỉ tóm được đúng 1 em đầu tiên.

 

[ChanhTQ@]

Ờ hén! Vậy không thể rút gọn bằng cách đó, vậy cách khác xem sao?!

Nếu j > SoCong1 mà thoát, sẽ chỉ liệt kê được 220 em thôi!

Mình nghĩ ra thêm cách này:
Thay vì 1 vòng lặp bên trong, ta phân ra làm 3 vòng lặp, như kiểu vầy, được không vậy?

 Dim Tram As Byte, Chuc As Byte, DVi As Byte
'. . . . . '
'. . . . . '
    For Tram = 0 to 9
           For Chuc =0 To 9
                 For DVi = 0 To 9
                       If SoCong1 = Tram + Chuc + DVi then
                               ' Lệnh gán lên trang tính'
                       End If
 
    Next DVi, Chuc, Tram
' . . . . . . . . '

 

[ptm0412]

Tạm thời, thay vì dùng: If j > socong1 Then Exit For

Ta dùng: If j > socong1 * 100 Then Exit For

Giảm được 70.062 vòng lặp
Còn cách dùng 3 vòng For, để thử cái đã. Mà sao bạn không thử nhỉ? Hay đây là câu đố? Vậy câu đố có giải thưởng hông?

 

[ChanhTQ@]

Có tự làm, nhưng không theo kịp!

Tạm thời, thay vì dùng: If j > socong1 Then Exit For
Ta dùng: If j > socong1 * 100 Then Exit For
Giảm được 70.062 vòng lặp
Còn cách dùng 3 vòng For, để thử cái đã. Mà sao bạn không thử nhỉ? Hay đây là câu đố? Vậy câu đố có giải thưởng hông?

Option Explicit
Dim TrNgan As Long, ChNgan As Long, Ngan As Long, Tong As Long
Dim Chuc As Byte, DVi As Byte, Trieu As Byte, Tram As Byte
Sub BTap04()
 Dim sCol As String, Rng As Range, bColor As Byte
 Dim Dem As Integer
 
 Trieu = 1:                 Range("A1:j65500").NumberFormat = "000000"
 [a2] = 0:                  bColor = 33
 For TrNgan = 1 To 999
    bColor = bColor + 1:            Dem = 0
    Tong = TrNgan \ 100 + (TrNgan \ 10 Mod 10) + (TrNgan Mod 10)
    For Tram = 0 To 9
        For Chuc = 0 To 9
            For DVi = 0 To 9
                If Tong = Tram + Chuc + DVi Then
                    Dem = 1 + Dem
[COLOR=blue]'                    Set Rng = Cells(10009, Trieu).End(xlUp).Offset(1) '[/COLOR]
[COLOR=blue]'                    Rng.Value = TrNgan * 1000 + Tram * 100 + Chuc * 10 + DVi '[/COLOR]
[COLOR=blue]'                    Rng.Interior.ColorIndex = bColor '[/COLOR]
[COLOR=blue]'                    If Rng.Row > 8999 Then Trieu = Trieu + 1 '[/COLOR]
                End If
    Next DVi, Chuc, Tram
    Set Rng = Cells(10009, "B").End(xlUp).Offset(1)
    Rng = TrNgan & " - " & Dem
    If bColor > 40 Then bColor = 33
 Next TrNgan
End Sub

Kết quả Sub này, trong mọi trường hợp MAX(Dem)=75

Như đã nói ở trên: Sẽ hậu tạ mà!​

 

[ndu96081631]

Hôm nay lại học thêm được 1 THỦ THUẬT:

Next DVi, Chuc, Tram

1 lần NEXT 1 tá ---> Có lý!
.........................
Phong cách viết code không lẩn vào đâu được (nếu như không có ai đó là ĐỆ RUỘT của người mà em đang đề cập)
Ẹc... Ẹc...

 

[ptm0412]

Kết quả Sub này, trong mọi trường hợp MAX(Dem)=75

1. Biến Dem trong trường hợp này, là đếm số lượng kết quả, tất nhiên là ít, tổng Dem = 55.251 (Thiếu số 000 000, đủ là 55.252)

2. Thời gian chạy (bỏ qua tô màu và thống kê) là 37 giây

3. Tổng số lần duyệt cũng là 999.000, không bớt em nào. (Code bài 19 của mình, số lần duyệt là 999 x 999 = 998.001 => 7 giây, code bài 23 giảm 70.062 lần còn 927.939 lần duyệt => 6 giây)

Cũng dùng cách chia 3 vòng lặp, duyệt đủ 999.000 lần, 3 giây
Dùng thêm câu Exit For, giảm còn 750.375 lần duyệt, 2 giây:

Code chính, không kể khai báo biến và set Application các loại:

For i = 1 To 999
    So1 = i
    Sotinh1 = Right("000" & So1, 3)
    SoCong1 = Left(Sotinh1, 1) * 1 + Mid(Sotinh1, 2, 1) * 1 + Right(Sotinh1, 1) * 1
    For Tram = 0 To 9
           For Chuc = 0 To 9
                 For DVi = 0 To 9
                        xx = xx + 1
                       If SoCong1 = Tram + Chuc + DVi Then
                            Rowi = IIf(Rowi + 1 = 5501, 1, Rowi + 1)
                            Colj = Colj + IIf(Rowi = 1, 1, 0)
                            Cells(Rowi, Colj) = So1 * 1000 + Tram * 100 + Chuc * 10 + DVi
                            'Exit For'
                      End If
     Next DVi, Chuc, Tram
     Cells(i + 1, 14) = xx
Next

 

[ChanhTQ@]

Dùng con số 75 để thoát 3 vòng lặp cưỡng bức:

Option Explicit
Dim TrNgan As Long, ChNgan As Long, Ngan As Long, Tong As Long
Dim Chuc As Byte, DVi As Byte, Trieu As Byte, Tram As Byte
[B]Sub BTap04()[/B]
 Dim sCol As String, Rng As Range
 Dim Dem As Integer
 
 Trieu = 1:                      [a2] = 0
 Range("A1:j65500").NumberFormat = "000000"
 [i1] = Timer
 For TrNgan = 1 To 999
    Dem = 0
    Tong = TrNgan \ 100 + (TrNgan \ 10 Mod 10) + (TrNgan Mod 10)
    For Tram = 0 To 9
        For Chuc = 0 To 9
            For DVi = 0 To 9
                If Tong = Tram + Chuc + DVi Then
                    Dem = 1 + Dem
                    Set Rng = Cells(10009, Trieu).End(xlUp).Offset(1)
                    Rng.Value = TrNgan * 1000 + Tram * 100 + Chuc * 10 + DVi
                    If Rng.Row > 8999 Then Trieu = Trieu + 1
                    If Dem = 75 Then GoTo DenDay
                End If
    Next DVi, Chuc, Tram
DenDay:
 Next TrNgan
 Cells(65500, "I").End(xlUp).Offset(2).Value = Timer
[B]End Sub[/B]

Không biết có nhanh hơn không nữa!​

 

[ptm0412]

Không biết có nhanh hơn không nữa!

27 giây, bạn à
Còn 2 chuyện:

1. biến Dem tăng đặt dưới câu điều kiện If, nên cũng chỉ đếm số lượng kết quả, không thoát nhiều như dự kiến, (còn 935.175 lần), phải đưa vào chỗ khác

2. Chạy chậm có thể do phải end(xlup) liên tục chăng? thay đọan end(xlUp) thì giảm còn 10 giây

 

[ThuNghi]

Thấy mấy Bác bàn tán xôm tự, chắc tính kinh doanh số điện thọai, em cũng xin tham gia 1 phương án dùng find, code hơi vụng về mong các Bác lượng thứ. Em liệt kê như vậy nằm có thể Autofilter tìm theo nút.

Dim iTT As Integer, So As String, Data As Range, rngFound As Range
Dim Dem As Long, iDem As Long, iDem01 As Long
Sub TN()
Sheets("TN").Select
Range("C1") = Time()
With Application
  .DisplayAlerts = False:  .ScreenUpdating = False:  .Calculation = xlCalculationManual
End With
'*Tao day so'
[A2:B6000].ClearContents
[A2:A6000].NumberFormat = "000"
Range(Cells(2, 3), Cells(1001, 78)).ClearContents
Range(Cells(2, 3), Cells(1001, 78)).NumberFormat = "000 000"
For iTT = 0 To 999
    So = Right("000" & iTT, 3)
    Cells(iTT + 2, 1) = So
    Cells(iTT + 2, 2) = Val(Left(So, 1)) + Val(Mid(So, 2, 1)) + Val(Right(So, 1))
Next
Set Data = [A2:B1001]
With Data
    .Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End With
Set Data = [B1:B1001]
ir = 2: iC = 3
For iTT = 0 To 27
Set rngFound = Data(1)
    Dem = worksheetfunction.CountIf(Data, iTT)
    For iDem = 1 To Dem
        Set rngFound = Data.Find(iTT, After:=rngFound, LookIn:=xlFormulas, LookAt _
        :=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
        With rngFound
            'Phan nay lay so-so'
            Cells(ir, iC).Value = Format(.Offset(, -1).Value, "000") & Format(.Offset(, -1).Value, "000")
            'Phan nay lay so-so doi'
            iC01 = 1
            If Dem > 1 Then
                For iDem01 = 1 To iDem - 1
                    Cells(ir, iC + iC01).Value = Format(.Offset(, -1).Value, "000") & Format(.Offset(-iDem01, -1).Value, "000")
                    iC01 = iC01 + 1
                Next
                For iDem01 = Dem - 1 To iDem Step -1
                    Cells(ir, iC + iC01).Value = Format(.Offset(, -1).Value, "000") & Format(.Offset(iDem01, -1).Value, "000")
                    iC01 = iC01 + 1
                Next
            End If
           
        End With
        ir = ir + 1
    Next
Next
Set Data = Nothing: Set rngFound = Nothing
Range("D1") = Time()
With Application
  .DisplayAlerts = True: .ScreenUpdating = True: .Calculation = xlCalculationAutomatic
End With
End Sub

 

[ChanhTQ@]

Bài tập 03: Chỉ là thêm một bước nhỏ hay sao ấy chứ!

Bài tập 03: Thống kê các số có 06 chữ số, mà tổng ba số ở các cột lẻ bằng với tổng các số đứng ở cột chẵn.
Ví du 112233, 123420, 100001. . .

Rất cảm ơn PTM0412 cũng như các bạn đã quan tâm & chia sẻ.

Mong sẽ không là chuyện lê thê, dài dòng!

 

[ThuNghi]

Bài tập 03: Thống kê các số có 06 chữ số, mà tổng ba số ở các cột lẻ bằng với tổng các số đứng ở cột chẵn.
Ví du 112233, 123420, 100001. . .

Rất cảm ơn PTM0412 cũng như các bạn đã quan tâm & chia sẻ.

Mong sẽ không là chuyện lê thê, dài dòng!

Em nghĩ lấy đáp án ở trên và lấy số 1, 3, 5 là số hạng 1,2,3 và tương ứng 2, 4, 6 là 4,5,6

 

[ptm0412]

Bài cũ chưa xong: Còn giảm được số lần lặp

Bài tổng 3 số cuối bằng tổng 3 số đầu, còn có thể giảm số lần lặp:

1. Nhận xét rằng với 1 số trăm và 1 số chục cố định, có thể tính ra số đơn vị, không cần vòng lặp thứ 3 cho Dvi:
Dvi = SoCong1 - Tram - Chuc
Với điều kiện Dvi nằm trong khoảng 0 - 9
Vậy số lần lặp còn 100.000

    For Tram = 0 To 9
           For Chuc = 0 To 9
                 Dvi = Socong1 - Tram - Chuc
                 If Dvi <= 9 And Dvi >= 0 Then
                            Rowi = IIf(Rowi + 1 = 5501, 1, Rowi + 1)
                            Colj = Colj + IIf(Rowi = 1, 1, 0)
                            Cells(Rowi, Colj) = So1 * 1000 + Tram * 100 + Chuc * 10 + Dvi
                 End If
     Next Chuc, Tram

2. Ta còn có thể giảm số lần lặp Tram và Chuc nếu nhận xét rằng Tram + Chuc luôn <= SoCong1, vậy nếu Tram + Chuc > SoCong1 thì Exit For. Lúc này yên tâm rằng Dvi = SoCong1 - Tram - Chuc sẽ không bị âm, chỉ còn điều kiện Dvi <= 9, số vòng lặp là 82.280, thời gian là dưới 2 giây

Sub Lietke3()
Range("M5") = Time()
Range("A1:k5500").NumberFormat = "000 000"
With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        Cells(1, 1) = 0
        Rowi = 1
        Colj = 1
        Socong1 = 0
        Socong2 = 0
For i = 1 To 999
    So1 = i
    Sotinh1 = Right("000" & So1, 3)
    Socong1 = Left(Sotinh1, 1) * 1 + Mid(Sotinh1, 2, 1) * 1 + Right(Sotinh1, 1) * 1
    For Tram = 0 To 9
           For Chuc = 0 To 9
                If Tram + Chuc > Socong1 Then Exit For
                    Dvi = Socong1 - Tram - Chuc
                    If Dvi <= 9 Then
                        Rowi = IIf(Rowi + 1 = 5501, 1, Rowi + 1)
                        Colj = Colj + IIf(Rowi = 1, 1, 0)
                        Cells(Rowi, Colj) = So1 * 1000 + Tram * 100 + Chuc * 10 + Dvi
                    End If
    Next Chuc, Tram
Next


    Range("M6") = Time()
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[ChanhTQ@]

Quá mỹ mãn luôn!!

Bài cũ chưa xong: Còn giảm được số lần lặp
Bài tổng 3 số cuối bằng tổng 3 số đầu, còn có thể giảm số lần lặp:

Khác với lần đưa ra đề bài 02, khi đưa ra đề bài 03 mình đâu dám 'khóa tạm' bài 02!
Và Quả thật, kiến thức cộng đồng là vô biên, không coi trọng chuyện này là không xong!

To ThuNghi: Quả thật sau khi có bài 01 & 02 thì việc giải bài 03 như húp cháo!
Nhưng chúng ta thử tưởng tượng, một khi chưa có bài 01 & 02 xem; Cũng ê chứ nhỉ?!

Bài 04 (giành cho những người chưa tham gia topic quá 01 bài): Hãy thống kê các số có 7 chữ số, thỏa các điều kiện như sau:
* Bắt đầu từ số 3 hay số 5;
* Trong mỗi 1 số không có ký số nào trùng nhau;
(VDụ: 3456 098, 5309 714, . . . )

 

[ptm0412]

Số lượng số đạt yêu cầu là tổ hợp chập 7 của 10 và bằng:
= 10! / (10-7)! = 604.800

Vấn đề là đặt điều kiện cho đúng để VBA lấy ra.
Đã thử: 3 phút 20 giây.
Chưa tìm cách giảm số lần lặp, xin mời, ta cùng chia giải!

 

[ChanhTQ@]

Số lượng số đạt yêu cầu là tổ hợp chập 7 của 10 và bằng:
= 10! / (10-7)! = 604.800
Chưa tìm cách giảm số lần lặp, xin mời, ta cùng chia giải!

Nếu PTM0412 giải hay tham gia giải với ai, thì không có hậu tạ đâu nha!

Nhưng đề bài là chỉ lấy các số bắt đầu với ký số 3 hay 5 thôi;
Như vậy có phải tổ hợp chập 6 của 10 & đem nhân với 2?

 

[ptm0412]

Nếu PTM0412 giải hay tham gia giải với ai, thì không có hậu tạ đâu nha!

Không công bằng! hic hic!

Nhưng đề bài là chỉ lấy các số bắt đầu với ký số 3 hay 5 thôi;
Như vậy có phải tổ hợp chập 6 của 10 & đem nhân với 2?

Bằng tổ hợp chập 7 của 10 chia cho 5 = 120.960

Hoặc tổ hợp chập 6 của 9 nhân mí lị 2: = 2 x 9!/ (9 -6)! = 120.960

Còn tổ hợp chập 6 của 10 nhân 2 = 2 x 10!/ (10-6)! = 302.400 chắc là sai! Sure!

Note: QUÊN cái vụ bắt đầu bằng 3 hay bằng 5!
Kết quả mới nhất: 34 giây

 

[ChanhTQ@]

Không công bằng! hic hic!
Bằng tổ hợp chập 7 của 10 chia cho 5 = 120.960
Hoặc tổ hợp chập 6 của 9 nhân mí lị 2: = 2 x 9!/ (9 -6)! = 120.960
Kết quả mới nhất: 34 giây

1./ Ờ hén, "tổ hợp chập 6 của 10 nhân 2 = 2 x 10!/ (10-6)! = 302.400 chắc là sai! Sure!"
2./ So với 2'' của bài 2 thì 34'' là quá xa xĩ!
Mình đưa cái này lên, Thông cảm bỏ qua nếu dư thừa:

Sub VongLapNhayCoc()
 Dim Ww As Long, Zz As Byte
 For Ww = 30 To 59
    Zz = Zz + 1:            If Ww = 40 Then Ww = 50
 Next Ww
 MsgBox Zz
End Sub

 

[ptm0412]

Tại sao không là For Ww = 301 To 598 hoặc For Ww = 3012 To 5987???????

34 " là chạy đủ vòng mà! chưa giới hạn số lần lặp! (có cho lãnh giải đâu mà làm, buồn vậy đó)

 

[phamduylong]

Bài 04 (giành cho những người chưa tham gia topic quá 01 bài): Hãy thống kê các số có 7 chữ số, thỏa các điều kiện như sau:
* Bắt đầu từ số 3 hay số 5;
* Trong mỗi 1 số không có ký số nào trùng nhau;
(VDụ: 3456 098, 5309 714, . . . )

Mình còn chưa hiểu câu này : Hãy thống kê các số có 7 chữ số
Thống kê bằng cách duyệt danh sách số điện thoại (kết quả số điện thoại đẹp) hay chỉ áp dụng phép tính tổ hợp cho kết quả?

 

[ChanhTQ@]

Đúng là tiếng Việt!

Nếu dùng chữ 'Liệt kê' thay vì 'Thống kê' có phải hơn không; Xin rút kinh nghiệm.
Liệt kê tất tần tật đó bác! Số nào thỏa yêu cầu thì ghi lên trang tính!

 

[phamduylong]

Nếu dùng chữ 'Liệt kê' thay vì 'Thống kê' có phải hơn không; Xin rút kinh nghiệm.
Liệt kê tất tần tật đó bác! Số nào thỏa yêu cầu thì ghi lên trang tính!

Sub ChuSoKhongTrung liệt kê các số có 7 chữ số không trùng. Cột 1 (A) các số bắt đầu bằng 3, Cột 2 (B) các số bắt đầu bằng 5

Sub ChuSoKhongTrung()
Application.ScreenUpdating = False
r = 1
n1 = 3
For i = 1 To 2
  Select Case i
  Case 1: n1 = 3
  Case Else: n1 = 5
  End Select
  r = 1
  For n2 = 0 To 9
    If n2 <> n1 Then
      For n3 = 0 To 9
        If n3 <> n1 And n3 <> n2 Then
          For n4 = 0 To 9
            If n4 <> n1 And n4 <> n2 And n4 <> n3 Then
              For n5 = 0 To 9
                If n5 <> n1 And n5 <> n2 And n5 <> n3 And n5 <> n4 Then
                  For n6 = 0 To 9
                    If n6 <> n1 And n6 <> n2 And n6 <> n3 And n6 <> n4 And n6 <> n5 Then
                      For n7 = 0 To 9
                        If n7 <> n1 And n7 <> n2 And n7 <> n3 And n7 <> n4 And n7 <> n5 And n7 <> n6 Then
                          Cells(r, i) = n1 & n2 & n3 & n4 & n5 & n6 & n7
                          r = r + 1
                        End If
                      Next
                    End If
                  Next
                End If
              Next
            End If
          Next
        End If
      Next
    End If
  Next
Next
End Sub

Có thể tìm 1 lần nhiều số không trùng có chữ số đầu cho trước bằng cách chỉnh:

For i = 1 To 2
   Select Case i
   Case 1: n1 = 3
   Case Else: n1 = 5
   End Select

Ví dụ liệt kê các số có 7 chữ số không trùng có chữ số đầu tiên là 2,3,6,7,9:

For i = 1 To 5
   Select Case i
   Case 1: n1 = 2
   Case 2: n1 = 3
   Case 3: n1 = 6
   Case 4: n1 = 7
   Case Else: n1 = 9
   End Select

 

[ThuNghi]

Em cũng xin tham gia đèo bồng với các Bác, em dùng chủ yêu Find và Replace. Không biết có đúng không. Chỉ đầu số 3 và 6 số khác nhau em ra đáp số là 19*720=13.680, thời gian # 8". Chắc là thiếu rồi.
Các bác xem và chỉ bảo thêm.

Sub LietKeSo()
With Application
  .ScreenUpdating = False: .Calculation = xlCalculationManual
End With
Dim i As Long, iR As Long, iSo As String, iCll As Range
Dim tg, MyRng As Range, SubRng As Range
tg = Now()
iR = 1
[A1:S720].ClearContents
For i = 123456 To 654321
  iSo = CStr(i)
  If InStr(iSo, 6) > 0 And InStr(iSo, 5) > 0 And InStr(iSo, 4) > 0 And InStr(iSo, 3) > 0 And InStr(iSo, 2) > 0 And InStr(iSo, 1) > 0 Then
    'Cells(iR, 1).NumberFormat = "@"'
    Cells(iR, 1).Value = iSo
    iR = iR + 1
  End If
Next
iR = iR - 1
Set MyRng = Range(Cells(1, 1), Cells(iR, 1))
For j = 7 To 9
  For i = 1 To 6
    Range(Cells(1, 1 + i + k), Cells(iR, 1 + i + k)) = MyRng.Value
    Set SubRng = Range(Cells(1, 1 + i + k), Cells(iR, 1 + i + k))
    With SubRng
      .Replace What:=CStr(i), Replacement:=CStr(j), LookAt:=xlPart, _
        SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    End With
  Next
  k = k + 6
Next
Set MyRng = [A1:S720]
With MyRng
  '.Replace What:="3", Replacement:="0", LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=True'
  .Replace What:=3, Replacement:="x", LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End With
For Each iCll In MyRng
  iCll.Value = "3" & iCll.Value
Next
With MyRng
  .Replace What:="x", Replacement:=0, LookAt:=xlPart, _
  SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
End With
MsgBox Now() - tg
With Application
  .ScreenUpdating = False: .Calculation = xlCalculationManual
End With

End Sub

Sorry Bác, còn thiếu 3 vòng lặp nữa mà làm biếng rồi. Đối chiếu file của Thầy Long.

 

[ptm0412]

Code của Thầy Long: 6 giây
Code của em thuật toán tương tự, (6 vòng for cho số từ So2 đến So7), nhưng sao chỉ 3 giây?
Chỉ khác là em cho hiện lên mỗi cột 10.000 em, 12 cột dư xíu (480 em) bên cột 13.

Không dám đưa lên, sợ chủ topic la!

A a a! Xin lỗi Thầy Long, cũng 6 giây!

To Thu Nghi: chỉ có 13.680:

For i = 123456 To 654321

thiếu số 0 đầu dang 3 012 456: 6.720 em
thiếu 1 loạt số từ 3 654 701 trở về sau

 

[ChanhTQ@]

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

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ể!?

 

[ThuNghi]

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

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

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"

 

[ChanhTQ@]

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!

 

[ptm0412]

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:

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!

 

[phamduylong]

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

 

[ptm0412]

Lỗi code Thu Nghi ở chỗ này:

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

 

[ThuNghi]

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.

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

 

[boyxin]

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.

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

 

[ptm0412]

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"

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

 

[boyxin]

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"

Test code của bác Ptm

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

​

 

[ChanhTQ@]

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!

 

[phamduylong]

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.

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

 

[boyxin]

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ố)

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

 

[phamduylong]

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à:

For n2=0 to 9
  If n2 >= n1 Then

Mà không là:

For n2=n1 to 9

Thanh Boyxin

 

[phamduylong]

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.

 

[ThuNghi]

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

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

 

[boyxin]

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

 

[boyxin]

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ố

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

 

[ptm0412]

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

 

[boyxin]

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ố

 

[phamduylong]

Cứ nghĩ đề 6 yêu cầu nhiều, anh em phải có thời gian để làm bài. Nhưng anh em làm ngọt quá ! Và cú pháp càng lúc càng gọn.
Lấy ý từ Sub SoGanhTN của ThuNghi và định dạng của Boyxin viết Sub SoGanh (lần này cố loại các vòng lặp thừa, không biết có thể gọn hơn nữa không?)

Sub SoGanh()
Dim i As Long, n As Long, r As Long, Str3 As String
Application.ScreenUpdating = False
Cells.ClearContents
For i = 0 To 999
  For n = 0 To 9
    If i Mod 10 <> n Then
      r = r + 1
      Str3 = Format(i, "000")
      Cells(r, 1) = Str3 & n & Right(Str3, 1) & Mid(Str3, 3, 1) & Left(Str3, 1)
    End If
  Next
Next
[A1].CurrentRegion.NumberFormat = "000 0 000"
End Sub

 

[hoangvuluan]

Nếu tránh việc ghi dữ liệu trực tiếp ra Cell thì có thể cải tiến tốc độ thêm 1 ít.

Sub GPE_Boyxin_dung_array()
Dim i As Long, j As Long, k As Long, s2 As Long, soG As Variant
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    [A1].CurrentRegion.Clear
    [M1] = Timer
soG = [a1:a9000]
t = 0
For i = 0 To 999
    k = i Mod 10
    s2 = k * 100 + ((i \ 10) Mod 10) * 10 + (i \ 100)
    For j = 0 To 9
        If j <> k Then
            t = t + 1
            soG(t, 1) = Format(i, "000") & j & Format(s2, "000")
        End If
    Next
Next
[a1:a9000] = soG
    [A1].CurrentRegion.NumberFormat = "000 0 000"
    [M2] = Timer: [M3] = [M2] - [M1]
    [M4] = [A1].CurrentRegion.SpecialCells(2, 1).Count
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

 

[boyxin]

Nếu tránh việc ghi dữ liệu trực tiếp ra Cell thì có thể cải tiến tốc độ thêm 1 ít.

Tuyệt cú mèo

Đúng là thần tốc
code boyxin 0.328125"
code phamduylong 0.34375"
code hoangvuluan dùng array 0.046875" chỉ bằng 1/7 của 0.328125"

Từ cách dùng array như code bác hoangvuluan đã đưa ra ở trên boyxin sửa (bỏ 1 số phép tính) thì chỉ còn 0.03125"

Sub GPE_Array_New()
Dim i As Long, j As Long, s2 As String, soG As Variant
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    [A1].CurrentRegion.Clear
    [M1] = Timer
    soG = [a1:j900]
For j = 0 To 9
    r = 0
    For i = 0 To 999
        If j <> (i Mod 10) Then
            r = r + 1
            s2 = (i Mod 10) & ((i \ 10) Mod 10) & (i \ 100)
            soG(r, j + 1) = i & j & s2
        End If
Next: Next
    [a1:j900] = soG
    [M2] = Timer: [M3] = [M2] - [M1]
    [A1].CurrentRegion.NumberFormat = "000 0 000"
    [M4] = [A1].CurrentRegion.SpecialCells(2, 1).Count
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

 

[ChanhTQ@]

Đúng là "đừng có lúc nào tự thỏa mãn lâu quá".

Tạm gán biến 6D cho phương án của HoangVuLuan, ta dùng kiểu này soi rọi lại các phương án trước đây (như 1A, 1B, . . . . , 5B) xem sao ta?
Mà cũng nhờ các phương án 6A..6C ta mới có con số 9.000;
Vậy sinh ra câu hỏi: Nếu khi con số đó nó lên đến hàng vạn thì sẽ ra sao đây ta, về tốc độ í mà!?

Rất cảm ơn mọi người đã quan tâm đến Topic!

Bài tập 01: #1-#3;             Bài tập 02" #17
Bài tập 03: #29;                Bài tập 04: #32
Bài tập 05: #53;                Bài tập 06: #57

 

[ThuNghi]

Tạm gán biến 6D cho phương án của HoangVuLuan, ta dùng kiểu này soi rọi lại các phương án trước đây (như 1A, 1B, . . . . , 5B) xem sao ta?
Mà cũng nhờ các phương án 6A..6C ta mới có con số 9.000;
Vậy sinh ra câu hỏi: Nếu khi con số đó nó lên đến hàng vạn thì sẽ ra sao đây ta, về tốc độ í mà!?

Rất cảm ơn mọi người đã quan tâm đến Topic!

Em thấy dùng hàm mà liên quan đến text chạy sẽ chậm hơn, kết hợp Array (HVL) em làm thử code sau.
BoyXin test hộ nhé, máy của mình chạy như rùa.

Option Base 1
Option Explicit
Dim i As Long, j As Long, k As Long, myRng As Range, MaxTT As Long
Dim vStr As Variant
Sub SoGanhTN01()
Application.ScreenUpdating = False
k = 1
[A1:A65000].Clear
[B1] = Timer
MaxTT = 10000 '1000 cap * 10'
vStr = Range(Cells(1, 1), Cells(MaxTT, 1))
For j = 0 To 9
    For i = 0 To 999
        If j <> i Mod 10 Then
            If i < 100 Then
                vStr(k, 1) = i & j & i Mod 10 & Int(i / 10) & 0
                k = k + 1
            Else
                vStr(k, 1) = i & j & i Mod 10 & Int((i Mod 100) / 10) & Int(i / 100)
                k = k + 1
            End If
        End If
    Next
Next
Set myRng = Range(Cells(1, 1), Cells(k - 1, 1))
With myRng
    .Value = vStr
    .NumberFormat = "0000000"
End With
Set myRng = Nothing: Set vStr = Nothing
[B2] = Timer: [B3] = [B2] - [B1]
Application.ScreenUpdating = True
End Sub

 

[boyxin]

Em thấy dùng hàm mà liên quan đến text chạy sẽ chậm hơn, kết hợp Array (HVL) em làm thử code sau.
BoyXin test hộ nhé, máy của mình chạy như rùa.

code này test trên máy boyxin 0.0625" (cũng bài liệt kê số gánh này, Code cũ của bác ThuNghi: 1,515625")

 

[ptm0412]

Mà cũng nhờ các phương án 6A..6C ta mới có con số 9.000

Chỉ duy nhất bài 3: các ký số không trùng là ta biết trước số lượng các số đẹp bằng công thức tính tổ hợp, còn các bài khác thì không có cách tính nào chính xác, nếu có thì chỉ là phỏng tính. Vậy, phương án Array rất hay, nhưng phải chấp nhận việc sẽ có những giá trị zero trong mảng vì ta phải tạo 1 mảng có kích thước lớn hơn con số ước tính.

 

[hoangvuluan]

Trong trường hợp tổng quát thì khó để xác định chính xác kích thước của array. Nhưng riêng đối với bài 6 thì hoàn toàn tính ra được giá trị 9000.
Thứ nhất, mọi số có 3 chữ số từ 000 đến 999 đều tồn tại duy nhất một số là số ngược của nó.
Thứ hai, vì điều kiện chữ số ở giữa phải khác chữ số cuối của số 3 chữ số ở trước, do đó với mỗi chữ số cuối tồn tại 9 chữ số khác với nó.
Từ 2 điều này suy ra có chính xác 9000 chữ số phù hợp yêu cầu.

Trong các trường hợp khác, thường thì dùng biến varian để nhận vùng dữ liệu có thể vượt quá kích thước, sau khi thực hiện các phép tính, có thể Redim một biến mảng và thực hiện lại (các) lệnh gán nếu thấy cần thiết.

Thân!

 

[boyxin]

Tổng hợp kết quả 6 bài toán về các con số
Với lời giải của các bác trong topic này. Em có chỉnh sửa tý xíu theo cách dùng Array
(áp dụng vụng về, mong nhận được góp ý thêm)
​

1. Bài 1: 5.609375" (500 000 số)
2. Bài 2: 0.28125" (55 252 số)
3. Bài 3: 0.1875" (55 252 số)
4. Bài 4: 0.859375" (120 960 số)
5. Bài 5: 0.015625" (1 144 số)
6. Bài 6: 0.03125" (9 960 số)

(Thông số về thời gian ở trên là kết quả test trên máy của em )
-------------------------------
Trong VBA: khai báo biến tường minh cũng làm tăng tốc độ sử lý
​

 

[ChanhTQ@]

Hãy giúp tôi hiểu về đề bài toán này với

Đề bài 07:
Có bao nhiêu số chẵn gồm sáu chữ số khác nhau từng đôi một, trong đó chữ số đầu tiên là chữ số lẽ.

Bạn hãy cho vài ví dụ theo cách hiểu của bạn. Xin cảm ơn các bạn nhiều, nhiều vô kể. . .


Bài tập 08:
Có bao nhiêu số chẵn gồm sáu chữ số, trong đó luôn chứa ba chữ số lẽ & chúng đều lớn hơn 99 999. Bạn giúp tôi liệt kê chúng lên trang tính.
Ví dụ: 111222, . . ., 121416, . . . . 987654, . .

Bổ sung & sửa đổi (Ngày 09/12/08):
Đề bài 07 này tạm thời chưa ai hiểu được, vậy nên đã chuyển sang giải quyết đề bài 07 thay thế tại #85; Mong các bạn gần xa tích cực ủng hộ.
Rất xin cảm ơn!!

 

[hoangvuluan]

Hình như có tổng cộng 42.000 số thỏa mãn yêu cầu:
công thức tính là:
1. có 5 chữ số lẻ 1, 3, 5, 7, 9 đứng đầu mỗi nhóm số
2. có 5 chữ số chẵn 0, 2, 4, 6, 8 đứng cuối mỗi nhóm số
3. ở giữa có 4 số khác nhau với 2 vị trí đầu và cuối => có 8 số, chọn 4 trong 8 (tổ hợp chập 4 của 8: hàm Combin(8, 4) ) để tạo ra 1 hoán vị (4! - hàm Fact(4))
4. Tóm lại, số các số là: 5 * 5 * Fact(4) * Combin(8, 4) = 42.000

Không biết có gì sai sót không?

 

[hoangvuluan]

Và xem thử mã sau đã chạy đúng chưa:

Sub bai7()
Const sn = "0123456789"
Dim st As String
Dim ra As Range
Dim va As Variant
vt = 0
Set ra = [A1:A42000]
ra.ClearContents
va = ra
For c1 = 1 To 9 Step 2
    For c6 = 0 To 8 Step 2
        st = Replace(Replace(sn, c1 & "", ""), c6 & "", "")
        For c2 = 1 To 8
            For c3 = c2 + 1 To 8
                For c4 = c3 + 1 To 8
                    For c5 = c4 + 1 To 8
                    ss = c1 & Mid(st, c2, 1) & Mid(st, c3, 1) & Mid(st, c4, 1) & Mid(st, c5, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c2, 1) & Mid(st, c3, 1) & Mid(st, c5, 1) & Mid(st, c4, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c2, 1) & Mid(st, c4, 1) & Mid(st, c3, 1) & Mid(st, c5, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c2, 1) & Mid(st, c4, 1) & Mid(st, c5, 1) & Mid(st, c3, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c2, 1) & Mid(st, c5, 1) & Mid(st, c4, 1) & Mid(st, c3, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c2, 1) & Mid(st, c5, 1) & Mid(st, c3, 1) & Mid(st, c4, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c3, 1) & Mid(st, c2, 1) & Mid(st, c4, 1) & Mid(st, c5, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c3, 1) & Mid(st, c2, 1) & Mid(st, c5, 1) & Mid(st, c4, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c3, 1) & Mid(st, c4, 1) & Mid(st, c2, 1) & Mid(st, c5, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c3, 1) & Mid(st, c4, 1) & Mid(st, c5, 1) & Mid(st, c2, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c3, 1) & Mid(st, c5, 1) & Mid(st, c4, 1) & Mid(st, c2, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c3, 1) & Mid(st, c5, 1) & Mid(st, c2, 1) & Mid(st, c4, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c4, 1) & Mid(st, c2, 1) & Mid(st, c3, 1) & Mid(st, c5, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c4, 1) & Mid(st, c2, 1) & Mid(st, c5, 1) & Mid(st, c3, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c4, 1) & Mid(st, c3, 1) & Mid(st, c2, 1) & Mid(st, c5, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c4, 1) & Mid(st, c3, 1) & Mid(st, c5, 1) & Mid(st, c2, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c4, 1) & Mid(st, c5, 1) & Mid(st, c2, 1) & Mid(st, c3, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c4, 1) & Mid(st, c5, 1) & Mid(st, c3, 1) & Mid(st, c2, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c5, 1) & Mid(st, c2, 1) & Mid(st, c3, 1) & Mid(st, c4, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c5, 1) & Mid(st, c2, 1) & Mid(st, c4, 1) & Mid(st, c3, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c5, 1) & Mid(st, c3, 1) & Mid(st, c2, 1) & Mid(st, c4, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c5, 1) & Mid(st, c3, 1) & Mid(st, c4, 1) & Mid(st, c2, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c5, 1) & Mid(st, c4, 1) & Mid(st, c2, 1) & Mid(st, c3, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    ss = c1 & Mid(st, c5, 1) & Mid(st, c4, 1) & Mid(st, c3, 1) & Mid(st, c2, 1) & c6
                        vt = vt + 1
                        va(vt, 1) = ss
                    Next
                Next
            Next
        Next
    Next
Next
ra = va
End Sub

 

[boyxin]

Em lại tính ra 143750 số thỏa mãn điều kiện


Số thỏa mãn yêu cầu: n = n1 - n2 - n3 - n4 - n5 - n6

• Các số chẵn <=> n6 luôn là số chẵn
• các số > 99 999 <=> n1 > 0

1. Lẻ - Lẻ - Lẻ - Chẵn - Chẵn - Chẵn = 5 * 5 * 5 * 5 * 5 * 5 = 15625 số
2. Lẻ - Lẻ - Chẵn - Lẻ - Chẵn - Chẵn = 5 * 5 * 5 * 5 * 5 * 5 = 15625 số
3. Lẻ - Lẻ - Chẵn - Chẵn - Lẻ - Chẵn = 5 * 5 * 5 * 5 * 5 * 5 = 15625 số
4. Lẻ - Chẵn - Lẻ - Lẻ - Chẵn - Chẵn = 5 * 5 * 5 * 5 * 5 * 5 = 15625 số
5. Lẻ - Chẵn - Chẵn - Lẻ - Lẻ - Chẵn = 5 * 5 * 5 * 5 * 5 * 5 = 15625 số
6. Lẻ - Chẵn - Lẻ - Chẵn - Lẻ - Chẵn = 5 * 5 * 5 * 5 * 5 * 5 = 15625 số
7. Chẵn - Lẻ- Chẵn - Lẻ - Lẻ - Chẵn = 4 * 5 * 5 * 5 * 5 * 5 = 12500 số
8. Chẵn - Lẻ- Lẻ - Chẵn - Lẻ - Chẵn = 4 * 5 * 5 * 5 * 5 * 5 = 12500 số
9. Chẵn - Lẻ- Lẻ - Lẻ - Chẵn - Chẵn = 4 * 5 * 5 * 5 * 5 * 5 = 12500 số
10. Chẵn - Chẵn - Lẻ- Lẻ - Lẻ - Chẵn = 4 * 5 * 5 * 5 * 5 * 5 = 12500 số

Tổng số = 6 * 15625 + 4 * 12500 = 143750

 

[ChanhTQ@]

Em lại tính ra 153750 số thỏa mãn điều kiện

Hình như BoyXin đang tính cho bài 08, phải không?

Bổ sung:

Rất vui vì qua 1 tuần tồn tại, Topic của chúng ta có hơn 70 bài viết & trung bình mỗi ngày có 200 lượt thành viên ghé qua xem xét.

Xin Cảm ơn các bạn, những thành viên đã quan tâm & nhất là viết bài cho Topic này!

Rất trân trọng!

 

[boyxin]

Bài 8

Sub bai8()
Dim Rng As Variant, iR As Long
Dim n1 As Long, n2 As Long, n3 As Long, n4 As Long, n5 As Long, n6 As Long
[A1:I18750].Clear
Rng = [A1:B18750]
[K1] = Timer
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
For n1 = 1 To 2
    iR = 0
    For n6 = 0 To 8 Step 2
        For n = 0 To 9999
            n2 = (n \ 1000): n3 = (n \ 100) Mod 10: n4 = (n \ 10) Mod 10: n5 = n Mod 10
            If n1 Mod 2 = 1 Then
                If (n2 * n3 Mod 2 = 1) And (n4 Mod 2 = 0) And (n5 Mod 2 = 0) _
                    Or (n2 * n4 Mod 2 = 1) And (n3 Mod 2 = 0) And (n5 Mod 2 = 0) _
                    Or (n2 * n5 Mod 2 = 1) And (n3 Mod 2 = 0) And (n4 Mod 2 = 0) _
                    Or (n3 * n4 Mod 2 = 1) And (n2 Mod 2 = 0) And (n5 Mod 2 = 0) _
                    Or (n3 * n5 Mod 2 = 1) And (n2 Mod 2 = 0) And (n4 Mod 2 = 0) _
                    Or (n4 * n5 Mod 2 = 1) And (n2 Mod 2 = 0) And (n3 Mod 2 = 0) Then
                    iR = iR + 1
                    Rng(iR, n1) = n1 & n2 & n3 & n4 & n5 & n6
                End If
            Else
                If (n2 * n3 * n4 Mod 2 = 1) And (n5 Mod 2 = 0) _
                    Or (n2 * n3 * n5 Mod 2 = 1) And (n4 Mod 2 = 0) _
                    Or (n2 * n4 * n5 Mod 2 = 1) And (n3 Mod 2 = 0) _
                    Or (n3 * n4 * n5 Mod 2 = 1) And (n2 Mod 2 = 0) Then
                    iR = iR + 1
                    Rng(iR, n1) = n1 & n2 & n3 & n4 & n5 & n6
                End If
            End If
Next: Next: Next
[A1:B18750] = Rng
[C1:I18750].FormulaR1C1 = "=RC[-2]+200000"
[C1:I18750] = [C1:I18750].Value
[D12501:D18750].Clear: [F12501:F18750].Clear: [H12501:H18750].Clear
[K2] = Timer: [K3] = [K2] - [K1]
[K4] = [A1:I18750].SpecialCells(2, 1).Count
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

Liệt kê được 143 750 số
--------------------------------
Sửa code theo góp ý của Bác Ptm0412 bài #80 : 0.765625"

 

[ptm0412]

= 4 * 5 * 5 * 5 * 5 * 5 = 15000 số

4 * 5 * 5 * 5 * 5 * 5 = 4 * 5^5 = 12.500
15.625 * 6 + 12.500 * 4 = 143.750

Boy xin xem chỗ này: số 5 đỏ lẽ ra là 3

If s > 2 And s Mod 2 = 1 Then
   If (n1 * n2 * n3 Mod 2 = 1) Or (n1 * n2 * n4 Mod 2 = 1) Or (n1 * n2 * n5 Mod 2 = 1) _
     Or (n2 * n3 * n4 Mod 2 = 1) Or (n2 * n3 * n5 Mod 2 = 1) Or _
        (n[B][COLOR="Red"]5[/COLOR][/B] * n4 * n5 Mod 2 = 1) Then

Thuật toán của cả Hvl và boyxin vẫn chưa đúng ở chỗ: If s > 2 And s Mod 2 = 1: Liệt kê luôn mấy em có 1 số lẻ và số có 5 số lẻ, vì các số này cũng thoả đk s Mod 2 = 1

ngoài ra: n1 + n2 + n3 Mod 2 <> (n1 + n2 + n3) Mod 2
và: n4 + n5 Mod 2 <> (n4 + n5) Mod 2

Còn nữa: Code của Hvl: And ((n4 + n5) Mod 2 = 0)) không bảo đảm cả n4 và n5 đều chẵn. Muốn bảo đảm cả n4 và n5 đều chẵn thì chỉ có thể And (n4 Mod 2 = 0 And n5 Mod 2 = 0)

 

[boyxin]

Nhưng 143.750 hình như cũng chưa đúng!

Cảm ơn bác đã góp ý: Em đã sửa code và vẫn cho ra 143.750 số

Tổng số 143.750 là chính xác rồi đó

 

[ptm0412]

Code của Boyxin giữ nguyên, nhưng chỉ cần cho kết quả 2 cột A và B, các cột còn lại thì dùng lệnh

Range(...).FormulaR1C1 = "=RC[-2]+200000"
Range(...)=Range(...).Value

giảm còn 1/3 thời gian, chỉ cần chú ý cột cao cột thấp.

 

[boyxin]

Một cách củ chuối nhưng bù lại được cái tốc độ ​

Sub Bia8_new()
Dim Rng As Variant, iR As Long
Dim n1 As Long, n2 As Long, n3 As Long, n4 As Long, n5 As Long, n6 As Long
[A1:J15625].Clear
Rng = [A1:J15625]
[m1] = Timer
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
'1) L L L C C C
For n1 = 1 To 9 Step 2
    For n2 = 1 To 9 Step 2
        For n3 = 1 To 9 Step 2
            For n4 = 0 To 8 Step 2
                For n5 = 0 To 8 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 1) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next: iR = 0
'2) L L C L C C
For n1 = 1 To 9 Step 2
    For n2 = 1 To 9 Step 2
        For n3 = 0 To 8 Step 2
            For n4 = 1 To 9 Step 2
                For n5 = 0 To 8 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 2) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next: iR = 0
'3) L L C C L C
For n1 = 1 To 9 Step 2
    For n2 = 1 To 9 Step 2
        For n3 = 0 To 8 Step 2
            For n4 = 0 To 8 Step 2
                For n5 = 1 To 9 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 3) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next: iR = 0
'4) L C L L C C
For n1 = 1 To 9 Step 2
    For n2 = 0 To 9 Step 2
        For n3 = 1 To 9 Step 2
            For n4 = 1 To 9 Step 2
                For n5 = 0 To 8 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 4) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next: iR = 0
'5) L C C L L C
For n1 = 1 To 9 Step 2
    For n2 = 0 To 8 Step 2
        For n3 = 0 To 8 Step 2
            For n4 = 1 To 9 Step 2
                For n5 = 1 To 9 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 5) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next: iR = 0
'6) L C L C L C
For n1 = 1 To 9 Step 2
    For n2 = 0 To 8 Step 2
        For n3 = 1 To 9 Step 2
            For n4 = 0 To 8 Step 2
                For n5 = 1 To 9 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 6) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next: iR = 0
'7) C L C L L C
For n1 = 2 To 8 Step 2
    For n2 = 1 To 9 Step 2
        For n3 = 0 To 8 Step 2
            For n4 = 1 To 9 Step 2
                For n5 = 1 To 9 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 7) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next: iR = 0
'8) C L L C L C
For n1 = 2 To 8 Step 2
    For n2 = 1 To 9 Step 2
        For n3 = 1 To 9 Step 2
            For n4 = 0 To 8 Step 2
                For n5 = 1 To 9 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 8) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next: iR = 0
'9) C L L L C C
For n1 = 2 To 8 Step 2
    For n2 = 1 To 9 Step 2
        For n3 = 1 To 9 Step 2
            For n4 = 1 To 9 Step 2
                For n5 = 0 To 8 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 9) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next: iR = 0
'10)C C L L L C
For n1 = 2 To 8 Step 2
    For n2 = 0 To 8 Step 2
        For n3 = 1 To 9 Step 2
            For n4 = 1 To 9 Step 2
                For n5 = 1 To 9 Step 2
                    For n6 = 0 To 8 Step 2
                        iR = iR + 1
                        Rng(iR, 10) = n1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: Next
[A1:J15625] = Rng
[m2] = Timer: [m3] = [m2] - [m1]
[m4] = [A1:J15625].SpecialCells(2, 1).Count
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

 

[ptm0412]

Tương tự bài trên, chỉ làm 3.125 dòng, sau đó:

Range("A3126:F15625").FormulaR1C1 = "=R[-3125]C+200000"
Range("G3126:J12500").FormulaR1C1 = "=R[-3125]C+200000"
Range("A3126:j15625") = Range("A3126:j15625").Value

Giảm còn 1/2 thời gian

 

[boyxin]

Code bài 8

Tương tự bài trên, chỉ làm 3.125 dòng, sau đó:

Range("A3126:F15625").FormulaR1C1 = "=R[-3125]C+200000"
Range("G3126:J12500").FormulaR1C1 = "=R[-3125]C+200000"
Range("A3126:j15625") = Range("A3126:j15625").Value

Giảm còn 1/2 thời gian

Dùng đoạn code này (Test tại máy của em 0.375") các bác kiểm tra lại giúp

Sub Bai8_03()
Dim Rng As Variant, iR As Long
Dim n2 As Long, n3 As Long, n4 As Long, n5 As Long, n6 As Long
[A1:J15625].Clear
Rng = [A1:A3125]
[m1] = Timer
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
For n2 = 1 To 9 Step 2
    For n3 = 1 To 9 Step 2
        For n4 = 0 To 9 Step 2
            For n5 = 0 To 9 Step 2
                For n6 = 0 To 9 Step 2
                    iR = iR + 1
                    Rng(iR, 1) = 1 & n2 & n3 & n4 & n5 & n6
Next: Next: Next: Next: Next: iR = 0
    [A1:A3125] = Rng
    [A3126:A15625].FormulaR1C1 = "=R[-3125]C+200000"
    [B1:B15625].FormulaR1C1 = "=RC1 - 900"
    [C1:C15625].FormulaR1C1 = "=RC1 - 990"
    [D1:D15625].FormulaR1C1 = "=RC1 - 9900"
    [E1:E15625].FormulaR1C1 = "=RC1 - 10890"
    [F1:F15625].FormulaR1C1 = "=RC1 - 9990"
    [G1:G12500].FormulaR1C1 = "=RC1 + 99110"
    [H1:H12500].FormulaR1C1 = "=RC1 + 100010"
    [I1:I12500].FormulaR1C1 = "=RC1 + 100100"
    [J1:J12500].FormulaR1C1 = "=RC1 + 90110"
    [A1:J15625] = [A1:J15625].Value
    [m2] = Timer: [m3] = [m2] - [m1]
    [m4] = [A1:J15625].SpecialCells(2, 1).Count
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

 

[boyxin]

V/v Bài 7

Đề bài 07:
Có bao nhiêu số chẵn gồm sáu chữ số khác nhau từng đôi một, trong đó chữ số đầu tiên là chữ số lẽ.

Không hiểu: Ý bác ChanhTQ@ muốn các số này có dạng như thế nào? khó hình dung quá

--------------------------------------------
Có phải là: số n = n1 - n2 - n3 - n4 - n5 - n6

1. Số chẵn <=> n6 luôn là số chẵn <=> n6 = { 0, 2, 4, 6, 8 }
2. Sáu chữ số khác nhau từng đôi một <=> trong 6 chữ số không có số nào giống nhau
3. Số đầu tiên lẻ <=> n1 = { 1, 3, 5, 7, 9 }

 

[ChanhTQ@]

Các bạn hỏi lại mình thì mình biết hỏi ai đây?

Hay ta chuyển nó sang đề bài khác đi:
Bài 7: Có bao nhiêu số có 6 cữ số, mà tổng của cặp hai chữ số từ trái qua phải là bằng nhau, nhưng các cặp này có trị không trùng nhau
Ví dụ: 192837, 453627, . . . . . , 174435, . . . 177144,. . .

 

[ptm0412]

3.240 số, 0,17199 giây. Chưa thử giảm vòng lặp.

Sub LietKe()
Dim Arr As Variant
Range("M5") = Timer

With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
Rowi = 0
Colj = 0
Arr = Range("A1:a3240")
[a1:a5000].ClearContents

For S1 = 2 To 97
    Couple1 = Format(S1, "00")
    Scong = Int(Couple1 / 10) + Couple1 Mod 10
    For S2 = 2 To 97
        Couple2 = Format(S2, "00")
        If Int(S2 / 10) + S2 Mod 10 = Scong And S2 <> S1 Then
             For S3 = 2 To 97
                Couple3 = Format(S3, "00")
                If Int(S3 / 10) + S3 Mod 10 = Scong And S3 <> S2 And S3 <> S1 Then
                    Rowi = IIf(Rowi + 1 = 50001, 1, Rowi + 1)
                    Colj = Colj + IIf(Rowi = 1, 1, 0)
                    So = Couple1 & Couple2 & Couple3
                    Arr(Rowi, Colj) = So
                End If
            Next
        End If
    Next
Next
Range("A1:a3240") = Arr
[a1:a3240].NumberFormat = "00 00 00"

    Range("M6") = Timer
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[ChanhTQ@]

Hình như PTM ngại dùng toán tử "\" !?!

Scong = Int(Couple1 / 10) + Couple1 Mod 10

có thể thay bằng:

[COLOR=#0000bb][COLOR=#0000bb][COLOR=#0000bb]Scong [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]Couple1 \[/COLOR][COLOR=#0000bb]10[/COLOR][COLOR=#007700] + [/COLOR][COLOR=#0000bb]Couple1 Mod 10 [/COLOR][/COLOR]
[/COLOR]

& Xin rất cảm ơn mọi người đã & đang quan tâm đến Topic này!!

 

[boyxin]

3.240 số, 0,17199 giây. Chưa thử giảm vòng lặp.

Sub LietKe()
.........................................
For S1 = 2 To 97
    Couple1 = Format(S1, "00")
    Scong = Int(Couple1 / 10) + Couple1 Mod 10
    For S2 = 2 To 97
        Couple2 = Format(S2, "00")
        If Int(S2 / 10) + S2 Mod 10 = Scong And S2 <> S1 Then
             For S3 = 2 To 97
                Couple3 = Format(S3, "00")
                If Int(S3 / 10) + S3 Mod 10 = Scong And S3 <> S2 And S3 <> S1 Then
                    Rowi = IIf(Rowi + 1 = 50001, 1, Rowi + 1)
                    Colj = Colj + IIf(Rowi = 1, 1, 0)
                    So = Couple1 & Couple2 & Couple3
                    Arr(Rowi, Colj) = So
                End If
            Next
        End If
    Next
Next
.................
End Sub

Thay đoạn For ... Next như sau thấy code chạy nhanh hơn đáng kể (Từ 0.140625" còn 0.046875" )
​

Tmp = [A1:J324]
[A1].CurrentRegion.ClearContents

For n1 = 2 To 97
    S1 = (n1 \ 10) + (n1 Mod 10)
    For n2 = 2 To 97
        If (n2 \ 10) + (n2 Mod 10) = S1 And n2 <> n1 Then
             For n3 = 2 To 97
                If (n3 \ 10) + (n3 Mod 10) = S1 And n3 <> n1 And n3 <> n2 Then
                    iR = IIf(iR + 1 = 325, 1, iR + 1)
                    iC = iC + IIf(iR = 1, 1, 0)
                    Tmp(iR, iC) = (n1 \ 10) & (n1 Mod 10) & (n2 \ 10) & (n2 Mod 10) & (n3 \ 10) & (n3 Mod 10)
                End If
            Next
        End If
    Next
Next
[A1:J324] = Tmp
[A1].CurrentRegion.NumberFormat = "00 00 00"

 

[hoangvuluan]

Bài số 7

Đề bài 07:
Có bao nhiêu số chẵn gồm sáu chữ số khác nhau từng đôi một, trong đó chữ số đầu tiên là chữ số lẽ.

Bạn hãy cho vài ví dụ theo cách hiểu của bạn. Xin cảm ơn các bạn nhiều, nhiều vô kể. . .


Bài tập 08:
Có bao nhiêu số chẵn gồm sáu chữ số, trong đó luôn chứa ba chữ số lẽ & chúng đều lớn hơn 99 999. Bạn giúp tôi liệt kê chúng lên trang tính.
Ví dụ: 111222, . . ., 121416, . . . . 987654, . .

Bổ sung & sửa đổi (Ngày 09/12/08):
Đề bài 07 này tạm thời chưa ai hiểu được, vậy nên đã chuyển sang giải quyết đề bài 07 thay thế tại #85; Mong các bạn gần xa tích cực ủng hộ.
Rất xin cảm ơn!!

Bài số 7 (cũ) tôi đã đưa ra 1 phương án, hix, không ai bình luận gì, không biết có đúng ý người ra đề không. Không có phản hồi. Rồi bây giờ lại kết luận là : tạm thời chưa ai hiểu được. Tôi không hiểu lắm về kết luận này.(?)
Thân!

 

[boyxin]

Bài số 7 (cũ) tôi đã đưa ra 1 phương án, hix, không ai bình luận gì, không biết có đúng ý người ra đề không. Không có phản hồi. Rồi bây giờ lại kết luận là : tạm thời chưa ai hiểu được. Tôi không hiểu lắm về kết luận này.(?)
Thân!

Chẹp chẹp, cái này thì phải đề nghị chủ topic trả lời thôi

Hình như có tổng cộng 42.000 số thỏa mãn yêu cầu:
công thức tính là:
1. có 5 chữ số lẻ 1, 3, 5, 7, 9 đứng đầu mỗi nhóm số
2. có 5 chữ số chẵn 0, 2, 4, 6, 8 đứng cuối mỗi nhóm số
3. ở giữa có 4 số khác nhau với 2 vị trí đầu và cuối => có 8 số, chọn 4 trong 8 (tổ hợp chập 4 của 8: hàm Combin(8, 4) ) để tạo ra 1 hoán vị (4! - hàm Fact(4))
4. Tóm lại, số các số là: 5 * 5 * Fact(4) * Combin(8, 4) = 42.000

Không biết có gì sai sót không?

riêng boyxin nghĩ: Nếu thế này thì khác gì bài 4: thay đổi tý xíu
<=> bắt đầu = {3, 5} thay bằng {1, 3, 5, 7 , 9} + kết thúc = {0, 2, 4, 6, 8}
các chữ số khác nhau(vẫn giữ nguyên)

 

[ChanhTQ@]

Bài số 7 (cũ) tôi đã đưa ra 1 phương án, hix, không ai bình luận gì, không biết có đúng ý người ra đề không. Không có phản hồi. Rồi bây giờ lại kết luận là : tạm thời chưa ai hiểu được. Tôi không hiểu lắm về kết luận này.(?)

Nói nặng ra thì bạn làm như trên là lạc đề; Đề bài bảy iêu cầu đưa ra ví dụ, là chuỗi các số thỏa & như bạn hiều theo đề bài mà!

Nói vui vậy thôi, bản thân mình chưa hiểu nó thì sao mà nói được, thiệt tình!

Nói theo 'Kiếm hiệp chuyện", Hồi sau sẽ quay lại vấn đề, nếu xét thấy cần hiểu thêm tiếng Việt!

 

[hoangvuluan]

n số đôi một khác nhau

Khi người ta nói: cho n số đôi một khác nhau thì có nghĩa là trong n số đó không có bất kỳ 1 cặp số nào giống nhau, hay nói gọn lại là: tất cả các số trong n số đó đều không giống nhau.
Với cách hiểu này, thì ở bài 7 tôi đã tính ra 42000 số có 6 chữ số đáp ứng yêu cầu và đã trình bày 1 code in ra 42000 số này. Nhưng sau đó thì không thấy giám khảo bình luận gì nên tôi mới thắc mắc không biết đáp án và cách nghĩ của mình có đúng không?

Thân!

 

[SA_DQ]

Bài 09 đây, mại zô!

Dùng VBA để tìm các số mà các chữ cái dưới đây đang làm đại diện cho chúng:

WONDERFUL = (OODDF)^2​

 

[hoangvuluan]

Đáp án là:
W O N D E R F U L = 5 2 3 8 1 4 7 6 9
O O D D F = 2 2 8 8 7

 

[SA_DQ]

Đó chỉ là đáp số thôi; chưa phải là lời giải. . . .

Bạn nào chưa có macro nào tại Topic này hãy đưa ra lời giải xem sao!

 

[boyxin]

Dùng VBA để tìm các số mà các chữ cái dưới đây đang làm đại diện cho chúng:

WONDERFUL = (OODDF)^2

​

​

Với đoạn code sau: Trong chớp mắt đã tìm được duy nhất 1 giá trị như đáp án như hvl đã đưa ra:
​

Đáp án là:
W O N D E R F U L = 5 2 3 8 1 4 7 6 9
O O D D F = 2 2 8 8 7

Code đã Hide

Trót post code lên, đọc lại thấy yêu cầu

Bạn nào chưa có macro nào tại Topic này hãy đưa ra lời giải xem sao!

Nên đành phải Hide, sợ bị Bác HYen17 mắng thì tội

Thế có Macro tại topic này thì không được trả lời à?
​

 

[ChanhTQ@]

Bài 11: Hãy tìm các số thỏa điều kiện sau(dành cho tất cả):

Bằng VBA, hãy viết giúp tôi macro để tìm các số mà các ký tự dưới đây đang làm đại diện:

[B][SIZE=3]     twenty[/SIZE][/B]
[B][SIZE=3]  twenty[/SIZE][/B]
[B][SIZE=4][SIZE=3]+[/SIZE]    [/SIZE][SIZE=3]twenty[/SIZE][/B]
[B][SIZE=3]    ten[/SIZE][/B]
[B][SIZE=3]    ten[/SIZE][/B]
[B][SIZE=3]------------------[/SIZE][/B]
[B][SIZE=3] eighty[/SIZE][/B]

 

[boyxin]

Bằng VBA, hãy viết giúp tôi macro để tìm các số mà các ký tự dưới đây đang làm đại diện:

[B][SIZE=3]     twenty[/SIZE][/B]
[B][SIZE=3]  twenty[/SIZE][/B]
[B][SIZE=4][SIZE=3]+[/SIZE]    [/SIZE][SIZE=3]twenty[/SIZE][/B]
[B][SIZE=3]    ten[/SIZE][/B]
[B][SIZE=3]    ten[/SIZE][/B]
[B][SIZE=3]------------------[/SIZE][/B]
[B][SIZE=3] eighty[/SIZE][/B]

Có phải là twenty * 3 + ten * 2 = eighty
để anh em còn biết đường

 

[ChanhTQ@]

Đúng đó bạn & xin viết giúp các câu lệnh VBA;
Bằng cách giải khác, ta có:

i=7​

​

 

[boyxin]

Bằng VBA, hãy viết giúp tôi macro để tìm các số mà các ký tự dưới đây đang làm đại diện:

[B][SIZE=3]     twenty[/SIZE][/B]
[B][SIZE=3]  twenty[/SIZE][/B]
[B][SIZE=4][SIZE=3]+[/SIZE]    [/SIZE][SIZE=3]twenty[/SIZE][/B]
[B][SIZE=3]    ten[/SIZE][/B]
[B][SIZE=3]    ten[/SIZE][/B]
[B][SIZE=3]------------------[/SIZE][/B]
[B][SIZE=3] eighty[/SIZE][/B]

Kết quả duy nhất, nhưng code hơi củ chuối, đang tìm cách tồi ưu

twenty​

​

|

ten​

​

|

eighty​

​

|

123416​

|

134​

|

370516​

|

 

[hoangvuluan]

Đáp án là:

T W E N T Y = 1 2 3 4 1 6
T E N = 1 3 4
E I G H T Y = 3 7 0 5 1 6

 

[boyxin]

twenty * 3 + ten * 2 = eighty

Đúng đó bạn & xin viết giúp các câu lệnh VBA;
Bằng cách giải khác, ta có:

i=7​

​

Các bác kiểm tra giúp xem có sai sót gì không
​

Dim twenty As Long, ten As Long, eighty As Long
Dim nho_chuc As Long, nho_tram As Long, nho_nghin As Long, nho_van As Long
Dim t As Long, w As Long, e As Long, n As Long, y As Long, i As Long, g As Long, h As Long
Sub Bai11() 'twenty * 3 + ten * 2 = eighty
    [h1] = Timer: [a1].CurrentRegion.ClearContents
    ir = 1: [a1] = "twenty": [b1] = "ten": [c1] = "eighty"
For y = 0 To 9
    n = ((y \ 6) + 1) * 5 - y: nho_chuc = (y * 3 + n * 2) \ 10
    For te = 10 To 39
        t = te \ 10: e = te Mod 10: nho_tram = (t * 3 + e * 2 + nho_chuc) \ 10
        If t = (t * 3 + e * 2 + nho_chuc) Mod 10 Then
            h = (n * 3 + t * 2 + nho_tram) Mod 10: nho_nghin = (n * 3 + t * 2 + nho_tram) \ 10
            g = (e * 3 + nho_nghin) Mod 10: nho_van = (e * 3 + nho_nghin) \ 10
            For i = 0 To 9
                For w = 0 To 9
                If i = (w * 3 + nho_van) Mod 10 Then
    twenty = t & w & e & n & t & y: ten = t & e & n: eighty = e & i & g & h & t & y
If twenty * 3 + ten * 2 = eighty And _
    (t <> w) And (t <> e) And (t <> n) And (t <> y) And (t <> i) And (t <> g) And (t <> h) And _
    (w <> e) And (w <> n) And (w <> y) And (w <> i) And (w <> g) And (w <> h) And _
    (e <> n) And (e <> y) And (e <> i) And (e <> g) And (e <> h) And _
    (n <> i) And (n <> g) And (n <> h) And (y <> i) And (y <> g) And (y <> h) And _
    (i <> g) And (i <> h) And (g <> h) Then
    ir = ir + 1: Cells(ir, 1) = twenty: Cells(ir, 2) = ten: Cells(ir, 3) = eighty
End If: End If:  Next: Next: End If: Next: Next
    [h2] = Timer: [h3] = [h2] - [h1]
End Sub