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

[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