Tổ Hợp chập 4

[emgaingayngo]

emgaingayngo có bài toán như sau, xin các cao thủ GPE chỉ giúp:
Đối với cột A viết macro để lấy kết quả tổ hợp chập 4
Mở rộng : Viết macro cho D3:H12 để lấy kết quả tổ hợp chập 4
Xin xem file để hiểu rõ hơn. Thanks!

 

[SA_DQ]

Có ngay, có ngay!

Tham khảo cái ni trước nha: trên cột 'A'

Option Explicit
Sub ToHopChap4()
 On Error Resume Next
 Dim Zj As Integer, Zf As Byte, Zw As Byte, Zz As Byte
 Dim eRow As Long
 Const Gn As String = "-"
 
 eRow = [A65432].End(xlUp).Row:              Range("C1:C" & eRow + 9).Clear
 Range("A1:A" & eRow).SpecialCells(xlCellTypeBlanks).Select
 If Not Selection Is Nothing Then Selection.Delete Shift:=xlUp
 eRow = [A65432].End(xlUp).Row
 For Zf = 1 To eRow - 3
   For Zj = Zf + 1 To eRow - 2
      For Zw = Zj + 1 To eRow + 1
         For Zz = Zw + 1 To eRow
            [c65432].End(xlUp).Offset(1) = Cells(Zf, 1) & Gn & Cells(Zj, 1) & Gn _
               & Cells(Zw, 1) & Gn & Cells(Zz, 1)
 Next Zz, Zw, Zj, Zf
End Sub

 

[emgaingayngo]

Macro trên bị lỗi khi có 10 phần tử trong cột A HYen17 ơi?

Có khi nó gôm cả các dòng ghi chú của bạn vô làm luôn đó!

Không phải đâu, khi các phần tử nằm gần nhau nó del up hết nên code cứ chạy hoài. Đã thử qua file mới rồi cũng vậy.

 

[ptm0412]

Xin phép Bác HYen tí nhé.
Do dòng lệnh này:
If Not Selection Is Nothing Then Selection.Delete Shift:=xlUp

Trước khi chạy code phải để ô chọn nằm ngoài vùng có dữ liệu cột A. Kể cả khi chạy lần 2 lần 3...
Vì khi chạy lần 1, có 1 số ô đã được chọn và xoá, lần sau dù không có ô trống nó cũng xoá. (Xoá selection).
Muốn tránh điều này thì cho selection qua chỗ khác sau khi chạy code:

.... 
Cells(1,3).select
End Sub

Còn nữa, khi thử với 7 ô có số trở lên thì câu này xoá không hết:
Range("C1:C" & eRow + 9).Clear
Phải sửa lại xoá nhiều 1 chút:

Range("C1:C1000").Clear

 

[SA_DQ]

Đúng là còn sai hai chỗ!

Option Explicit
Sub ToHopChap4()
 On Error Resume Next
 Dim Zj As Integer, Zf As Byte, Zw As Byte, Zz As Byte
 Dim eRow As Long:            Dim bRng As Range '<<=='
 Const Gn As String = "-"
 
 eRow = [A65432].End(xlUp).Row
 Range([C1], [c65500].End(xlUp)).Clear  '<<=='
 Set bRng = Range("A1:A" & eRow).SpecialCells(xlCellTypeBlanks) '<<=='
 If Not bRng Is Nothing Then bRng.Delete Shift:=xlUp '<<=='

 eRow = [A65432].End(xlUp).Row
 For Zf = 1 To eRow - 3
   For Zj = Zf + 1 To eRow - 2
      For Zw = Zj + 1 To eRow + 1
         For Zz = Zw + 1 To eRow
            [c65432].End(xlUp).Offset(1) = Cells(Zf, 1) & Gn & Cells(Zj, 1) & Gn _
               & Cells(Zw, 1) & Gn & Cells(Zz, 1)
 Next Zz, Zw, Zj, Zf
End Sub