Các câu hỏi về mảng trong VBA (Array)

Liên hệ QC
viehoai

viehoai

Thành viên gắn bó
Tham gia
22/5/09
Bài viết
2,599
Được thích
2,908
Xin các anh chị giúp đỡ Code Gán các giá trị của một Range là các phần tử của Mãng
Ví dụ: Tôi có các giá trị của Range("A1:A10"). Tôi muốn viết code để gán giá trị của các cells từ A1:A10 là các phần tử của Mãng Arr chẳn hạn.
Xin cảm ơn các anh chị
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Ba Tê đã viết:
Vẫn mơ hồ.
- 2 sheet xét theo từng dòng từ cột A đến E?
- Nếu từng Cell có giá trị của 2 sheet khác nhau thì "tô màu", vậy nội dung trong cell kết quả ghi nội dung của sheet 1 hay sheet2?
- Cũng giải thích rõ kết quả trong sheet Result: E2, G2, I2 làm sao mà có? Quy luật là sao?
Nhấp chuột vào đây để mở rộng...
À đúng rồi, con hiểu rồi.
Nghĩa là thế này Thầy ạ, đúng là con mô tả sai không đúng mục đích. Con gửi lại file và xin phép xóa file kèm bài 1317 ạ
Lọc duy nhất A,B,C,D,E so sánh 2 sheet nếu khác nhau trả về kết quả ạ..( cột F ở 2 sheet là cột phụ minh họa), mong muốn code khác không phải sử dụng cột phụ F.
Và cuối cùng là lọc duy nhất kết quả khác nhau để trả về những giá trị duy nhất trong 1 cột E sheets("Results")
không sử dụng RemoveDuplicates mà cũng ra như kết quả như file kèm ạ.
Cảm ơn Thầy nhiều ạ

Sửa bổ sung: không sử dụng RemoveDuplicates (mất định dạng)
 

File đính kèm

  • So sanh 2 Sheet.xlsm
    23.4 KB · Đọc: 35
Lần chỉnh sửa cuối:
Upvote 0
Nguyễn Hoàng Oanh Thơ đã viết:
À đúng rồi, con hiểu rồi.
Nghĩa là thế này Thầy ạ, đúng là con mô tả sai không đúng mục đích. Con gửi lại file và xin phép xóa file kèm bài 1317 ạ
Lọc duy nhất A,B,C,D,E so sánh 2 sheet nếu khác nhau trả về kết quả ạ..( cột F ở 2 sheet là cột phụ minh họa), mong muốn code khác không phải sử dụng cột phụ F.
Và cuối cùng là lọc duy nhất kết quả khác nhau để trả về những giá trị duy nhất trong 1 cột E sheets("Results")
không sử dụng RemoveDuplicates mà cũng ra như kết quả như file kèm ạ.
Cảm ơn Thầy nhiều ạ

Sửa bổ sung: không sử dụng RemoveDuplicates (mất định dạng)
Nhấp chuột vào đây để mở rộng...
Biết xài "Dic" thì cứ "Dic" mà "quất".
PHP: 
Public Sub Gpe()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, Txt As String
Set Dic = CreateObject("Scripting.Dictionary")
    '===================================='
    sArr = Sheets("OLD").Range("A2", Sheets("OLD").Range("A2").End(xlDown)).Resize(, 5).Value
    R = UBound(sArr)
    For I = 1 To R
        Txt = Space(0)
        For J = 1 To 5
            Txt = Txt & sArr(I, J)
        Next J
        Dic.Item(Txt) = ""
    Next I
    '===================================='
    sArr = Sheets("NEW").Range("A2", Sheets("NEW").Range("A2").End(xlDown)).Resize(, 5).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 1)
    For I = 1 To R
        Txt = Space(0)
        For J = 1 To 5
            Txt = Txt & sArr(I, J)
        Next J
        If Not Dic.Exists(Txt) Then
            Dic.Item(Txt) = ""
            K = K + 1
            dArr(K, 1) = Txt
        End If
    Next I
    '===================================='
Sheets("Results").Range("E2").Resize(1000).ClearContents
Sheets("Results").Range("E2").Resize(K) = dArr
Set Dic = Nothing
End Sub
 
Upvote 0
Ba Tê đã viết:
Biết xài "Dic" thì cứ "Dic" mà "quất".
PHP: 
Public Sub Gpe()
Dim Dic As Object, sArr(), dArr(), I As Long, J As Long, K As Long, R As Long, Txt As String
Set Dic = CreateObject("Scripting.Dictionary")
    '===================================='
    sArr = Sheets("OLD").Range("A2", Sheets("OLD").Range("A2").End(xlDown)).Resize(, 5).Value
    R = UBound(sArr)
    For I = 1 To R
        Txt = Space(0)
        For J = 1 To 5
            Txt = Txt & sArr(I, J)
        Next J
        Dic.Item(Txt) = ""
    Next I
    '===================================='
    sArr = Sheets("NEW").Range("A2", Sheets("NEW").Range("A2").End(xlDown)).Resize(, 5).Value
    R = UBound(sArr)
    ReDim dArr(1 To R, 1 To 1)
    For I = 1 To R
        Txt = Space(0)
        For J = 1 To 5
            Txt = Txt & sArr(I, J)
        Next J
        If Not Dic.Exists(Txt) Then
            Dic.Item(Txt) = ""
            K = K + 1
            dArr(K, 1) = Txt
        End If
    Next I
    '===================================='
Sheets("Results").Range("E2").Resize(1000).ClearContents
Sheets("Results").Range("E2").Resize(K) = dArr
Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Con chào Thầy ạ,
Code trên chạy đúng ý con rồi,cảm ơn Thầy đã giúp đỡ.
 
Upvote 0
Mình có một file chấm công như file đính kém ở dưới. Mình muốn lập code về màng để điền công theo bảng đó (Đã lập được code dùng Range nhưng code chạy tương đối chậm). Nếu như hàng (E13:AH13) = "CN" thì các giá trị theo cột "CN" sẽ được điền là "S" còn lại từ thứ 2-7 thì sẽ được điền giá trị là "1".
 

File đính kèm

  • Hoivebangchamcong.xlsm
    80.8 KB · Đọc: 16
Upvote 0
Mọi người cho hỏi: Có một mảng gồm r hàng và c cột, làm thế nào để duyệt qua tất cả các tổ hợp, mỗi tổ hợp gồm r phần tử; trong mỗi tổ hợp: mỗi hàng có duy nhất một phần tử trong cột bất kỳ (tổng cộng có c^r tổ hợp). Duyệt qua được tất cả các tổ hợp mình sẽ chọn các tổ hợp thỏa mãn điều kiện sẽ lấy.
 
Lần chỉnh sửa cuối:
Upvote 0
thanhlanh đã viết:
Mọi người cho hỏi: Có một mảng gồm r hàng và c cột, làm thế nào để duyệt qua tất cả các tổ hợp, mỗi tổ hợp gồm r phần tử; trong mỗi tổ hợp: mỗi hàng có duy nhất một phần tử trong cột bất kỳ (tổng cộng có c^r tổ hợp). Duyệt qua được tất cả các tổ hợp mình sẽ chọn các tổ hợp thỏa mãn điều kiện sẽ lấy.
Nhấp chuột vào đây để mở rộng...
Dùng vòng lặp thì có lẽ là cho kết hợp tuần tự theo từng dòng từ trên xuống dưới. Mỗi lần kết hợp, lưu kết quả vào mảng trung gian, sau đó lấy mảng trung gian này ghép với dòng tiếp theo.
 
Upvote 0
CHAOQUAY đã viết:
Dùng vòng lặp thì có lẽ là cho kết hợp tuần tự theo từng dòng từ trên xuống dưới. Mỗi lần kết hợp, lưu kết quả vào mảng trung gian, sau đó lấy mảng trung gian này ghép với dòng tiếp theo.
Nhấp chuột vào đây để mở rộng...
Cho code cụ thể thử bạn, tôi tìm bể đâu chưa ra.
Nôm na giống thế này: Đi mua trái cây gồm nhiều loại: me, xoài, cốc, ổi ...; mỗi loại trái có nhiều loại ngon dỡ chất lượng khác nhau nên giá cũng nhiều loại giá khác nhau, từ 1,2,5,...,100 đồng một bịch, kể cả có loại khuyến mãi 0 đồng. Bây giờ tôi có 100 đồng nhưng muốn mua tất cả các loại quả, mỗi loại chỉ một bịch. Tìm cho tôi tất cả các phương án mua mỗi loại trái cây một bịch sao cho tổng số tiền không quá 100 đồng (có thể càng tiệm cận 100 đồng càng tốt)?
Bài đã được tự động gộp:

CHAOQUAY đã viết:
Dùng vòng lặp thì có lẽ là cho kết hợp tuần tự theo từng dòng từ trên xuống dưới. Mỗi lần kết hợp, lưu kết quả vào mảng trung gian, sau đó lấy mảng trung gian này ghép với dòng tiếp theo.
Nhấp chuột vào đây để mở rộng...
Cho code cụ thể thử bạn, tôi tìm bể đâu chưa ra.
Nôm na giống thế này: Đi mua trái cây gồm nhiều loại: me, xoài, cốc, ổi ...; mỗi loại trái có nhiều loại ngon dỡ chất lượng khác nhau nên giá cũng nhiều loại giá khác nhau, từ 1,2,5,...,100 đồng một bịch, kể cả có loại khuyến mãi 0 đồng. Bây giờ tôi có 100 đồng nhưng muốn mua tất cả các loại quả, mỗi loại chỉ một bịch. Tìm cho tôi tất cả các phương án mua mỗi loại trái cây một bịch sao cho tổng số tiền không quá 100 đồng (có thể càng tiệm cận 100 đồng càng tốt)?
 
Upvote 0
thanhlanh đã viết:
Cho code cụ thể thử bạn, tôi tìm bể đâu chưa ra.
Nôm na giống thế này: Đi mua trái cây gồm nhiều loại: me, xoài, cốc, ổi ...; mỗi loại trái có nhiều loại ngon dỡ chất lượng khác nhau nên giá cũng nhiều loại giá khác nhau, từ 1,2,5,...,100 đồng một bịch, kể cả có loại khuyến mãi 0 đồng. Bây giờ tôi có 100 đồng nhưng muốn mua tất cả các loại quả, mỗi loại chỉ một bịch. Tìm cho tôi tất cả các phương án mua mỗi loại trái cây một bịch sao cho tổng số tiền không quá 100 đồng (có thể càng tiệm cận 100 đồng càng tốt)?
Bài đã được tự động gộp:


Cho code cụ thể thử bạn, tôi tìm bể đâu chưa ra.
Nôm na giống thế này: Đi mua trái cây gồm nhiều loại: me, xoài, cốc, ổi ...; mỗi loại trái có nhiều loại ngon dỡ chất lượng khác nhau nên giá cũng nhiều loại giá khác nhau, từ 1,2,5,...,100 đồng một bịch, kể cả có loại khuyến mãi 0 đồng. Bây giờ tôi có 100 đồng nhưng muốn mua tất cả các loại quả, mỗi loại chỉ một bịch. Tìm cho tôi tất cả các phương án mua mỗi loại trái cây một bịch sao cho tổng số tiền không quá 100 đồng (có thể càng tiệm cận 100 đồng càng tốt)?
Nhấp chuột vào đây để mở rộng...
Code dưới đây viết theo nội dung của bài 1324 ở trên.
Bạn điểu chỉnh thêm bớt hoặc gửi file giả định lên giải quyết cho tiện
Mã: 
Option Explicit

Sub TestVonglap()
Dim Nguon, Dong, Cot
Dim Mang
Dim DicTT As Object
Dim i, j, k

Set DicTT = CreateObject("Scripting.Dictionary")
Nguon = Sheet1.Range("A1:C5")

Dong = UBound(Nguon)
Cot = UBound(Nguon, 2)
ReDim Mang(Cot - 1)
For j = 1 To Cot
    Mang(j - 1) = Nguon(1, j)
Next j
k = 1
Do While k < Dong
    k = k + 1
    DicTT.RemoveAll
    For i = 0 To UBound(Mang)
        For j = 1 To Cot
            DicTT(Mang(i) & " " & Nguon(k, j)) = ""
        Next j
    Next i
    Mang = DicTT.Keys
Loop
With Sheet2
    .UsedRange.Clear
    .Range("C1").Resize(DicTT.Count, 1) = WorksheetFunction.Transpose(DicTT.Keys)
End With
End Sub
 
Upvote 0
thanhlanh đã viết:
Cho code cụ thể thử bạn, tôi tìm bể đâu chưa ra.
Nôm na giống thế này: Đi mua trái cây gồm nhiều loại: me, xoài, cốc, ổi ...; mỗi loại trái có nhiều loại ngon dỡ chất lượng khác nhau nên giá cũng nhiều loại giá khác nhau, từ 1,2,5,...,100 đồng một bịch, kể cả có loại khuyến mãi 0 đồng. Bây giờ tôi có 100 đồng nhưng muốn mua tất cả các loại quả, mỗi loại chỉ một bịch. Tìm cho tôi tất cả các phương án mua mỗi loại trái cây một bịch sao cho tổng số tiền không quá 100 đồng (có thể càng tiệm cận 100 đồng càng tốt)?
Nhấp chuột vào đây để mở rộng...
Cái này là bài toán ba lô (knapsack problem).
Đem ra nói chuyện ở đề tài "mảng" thì tìm lên trời còn không ra chứ đừng nói chuyện "tìm bể dâu chưa ra"

Bài giải không giản dị nhưng nó là căn bản của lập trình quy hoạch. Muốn tiếng Anh hay tiếng Việt thì tôi đã mách cho đủ từ khoá rồi. Gú gô sẽ ra cả đống.
 
Upvote 0
CHAOQUAY đã viết:
Code dưới đây viết theo nội dung của bài 1324 ở trên.
Bạn điểu chỉnh thêm bớt hoặc gửi file giả định lên giải quyết cho tiện
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhiều, để mình nghiên cứu tiếp "cộng tiền trong ba lô". Bạn quá siêu!
Bài đã được tự động gộp:

VetMini đã viết:
Cái này là bài toán ba lô (knapsack problem).
Đem ra nói chuyện ở đề tài "mảng" thì tìm lên trời còn không ra chứ đừng nói chuyện "tìm bể dâu chưa ra"

Bài giải không giản dị nhưng nó là căn bản của lập trình quy hoạch. Muốn tiếng Anh hay tiếng Việt thì tôi đã mách cho đủ từ khoá rồi. Gú gô sẽ ra cả đống.
Nhấp chuột vào đây để mở rộng...
Cảm ơn anh cho tôi biết các khái niệm trong lập trình, vì là dân lập trình a-ma-tơ nên lần đầu tôi biết bài toán ba lô. Còn chuyện tìm bể đâu thực ra là nói bể đầu, nghĩ nát óc tìm chưa ra. hihi (lỗi tại thằng đánh máy)
 
Lần chỉnh sửa cuối:
Upvote 0
thanhlanh đã viết:
Cảm ơn bạn nhiều, để mình nghiên cứu tiếp "cộng tiền trong ba lô". Bạn quá siêu!
Bài đã được tự động gộp:


Cảm ơn anh cho tôi biết các khái niệm trong lập trình, vì là dân lập trình a-ma-tơ nên lần đầu tôi biết bài toán ba lô. Còn chuyện tìm bể đâu thực ra là nói bể đầu, nghĩ nát óc tìm chưa ra. hihi (lỗi tại thằng đánh máy)
Nhấp chuột vào đây để mở rộng...
Bạn có thể tìm từ khoá " thuật toán tham lam" nó sẽ ra rất nhiều nguồn để tham khảo
 
Upvote 0
ACE giúp mình lấy dữ liệu từ Sheets("Data") là mảng 1 chiều sang sheets("Sua") là 1 mảng 2 chiều ( 1 to 3, 1 to (lastcol-1)/3).
 

File đính kèm

  • Helpme.xlsm
    19 KB · Đọc: 12
Upvote 0
Bạn thử với củ khoai sùng này trước nha, trong khi chờ đợi:
PHP: 
Sub EditHD()
  Dim Rng As Range, sRng As Range
  Dim J As Long, Rws As Long, Col As Integer, Dg As Integer
  Dim TD As String
    
   [B1].CurrentRegion.Offset(1, 1).ClearContents
  With Sheets("Data")
        Rws = .[A1].CurrentRegion.Rows.Count
        Col = .[A1].CurrentRegion.Columns.Count
        Set Rng = .[A1].Resize(Rws):                Dg = 2
        Set sRng = Rng.Find([K1].Value, , xlFormulas, xlWhole)
        If sRng Is Nothing Then
            MsgBox "Nothing"
        Else
            For J = 1 To Col - 1
                TD = .Cells(1, sRng.Offset(, J).Column).Value
                Col = Switch(TD = "MH", 1, TD = "SH", 2, TD = "DH", 3, TD = "", 9)
                Cells(Dg, 1 + Col).Value = sRng.Offset(, J).Value
                If J Mod 3 = 0 Then Dg = Dg + 1
            Next J
        End If
   End With
End Sub
 
Upvote 0
Ty Bác, đúng cái yêu cầu mà mỗi tội Em phải đọc thêm mấy cái nữa. may ra mới hiểu tại sao.
 
Upvote 0
thanhlanh đã viết:
Cho code cụ thể thử bạn, tôi tìm bể đâu chưa ra.
Nôm na giống thế này: Đi mua trái cây gồm nhiều loại: me, xoài, cốc, ổi ...; mỗi loại trái có nhiều loại ngon dỡ chất lượng khác nhau nên giá cũng nhiều loại giá khác nhau, từ 1,2,5,...,100 đồng một bịch, kể cả có loại khuyến mãi 0 đồng. Bây giờ tôi có 100 đồng nhưng muốn mua tất cả các loại quả, mỗi loại chỉ một bịch. Tìm cho tôi tất cả các phương án mua mỗi loại trái cây một bịch sao cho tổng số tiền không quá 100 đồng (có thể càng tiệm cận 100 đồng càng tốt)?
Bài đã được tự động gộp:


Cho code cụ thể thử bạn, tôi tìm bể đâu chưa ra.
Nôm na giống thế này: Đi mua trái cây gồm nhiều loại: me, xoài, cốc, ổi ...; mỗi loại trái có nhiều loại ngon dỡ chất lượng khác nhau nên giá cũng nhiều loại giá khác nhau, từ 1,2,5,...,100 đồng một bịch, kể cả có loại khuyến mãi 0 đồng. Bây giờ tôi có 100 đồng nhưng muốn mua tất cả các loại quả, mỗi loại chỉ một bịch. Tìm cho tôi tất cả các phương án mua mỗi loại trái cây một bịch sao cho tổng số tiền không quá 100 đồng (có thể càng tiệm cận 100 đồng càng tốt)?
Nhấp chuột vào đây để mở rộng...
Mỗi loại trái cây chỉ có thể mua 1 bịch hoặc 0 nên có thể dùng vòng lặp cho biến i chạy từ 1 đến 2^n, n là số loại, số bịch loại trái cây thứ k chính là chữ số thứ k trong biểu diễn nhị phân của i. Từ đó có thể tìm ra tất cả các cách mua và cách mua có số tiền gần đúng nhất.
Mã: 
Option Explicit
Sub a()
    Dim Max, tmpMax, i, j, k, m, N, Tong
    Dim Sarr(), KQ(), KQ2()
    Sarr = Range("A1:K1")
    N = UBound(Sarr, 2)
    
    ReDim KQ(1 To 1000000)
    Max = 100
    tmpMax = 0
    k = 0
    For m = 1 To 2 ^ N
        Tong = 0
        For i = 1 To N
            If (m And 2 ^ (i - 1)) > 0 Then Tong = Tong + Sarr(1, i)
            If Tong > Max Then GoTo Thoat
        Next
        If Tong > tmpMax And Tong <= Max Then
            tmpMax = Tong
            k = 1
            KQ(k) = m
        ElseIf Tong = tmpMax Then
            k = k + 1
            KQ(k) = m
        End If
Thoat:
    Next
    
    ReDim KQ2(1 To k, 1 To N)
    For i = 1 To k
        For j = 1 To N
            KQ2(i, j) = IIf((KQ(i) And 2 ^ (j - 1)) > 0, 1, 0)
        Next
    Next
    Range("A2").Resize(k, N) = KQ2
    
End Sub
 

File đính kèm

  • Book1.xlsm
    14.9 KB · Đọc: 10
Upvote 0
thanhlanh đã viết:
Mọi người cho hỏi: Có một mảng gồm r hàng và c cột, làm thế nào để duyệt qua tất cả các tổ hợp, mỗi tổ hợp gồm r phần tử; trong mỗi tổ hợp: mỗi hàng có duy nhất một phần tử trong cột bất kỳ (tổng cộng có c^r tổ hợp). Duyệt qua được tất cả các tổ hợp mình sẽ chọn các tổ hợp thỏa mãn điều kiện sẽ lấy.
Nhấp chuột vào đây để mở rộng...
Rảnh rổi nên lục lại bài xa xưa :)
Dùng hàm Mod và Int xác định dòng dữ liệu tổ hợp
Dữ liệu có thể nhập lung tung như trong file, nếu dữ liệu không có ô trống, Sub CreateArrDaTa sẽ gọn hơn
Mã: 
Sub DuyetToHop()
  Dim sArr(), aRow(), Res()
  Dim sCol&, sRow&, N&, k&, i&, j&, iR&
  Dim tMax As Double, Tong As Double
 
  sArr = Range("A2:E8").Value
  sRow = UBound(sArr, 1):   sCol = UBound(sArr, 2)
  ReDim aRow(1 To sCol + 1)
  Call CreateArrDaTa(sArr, aRow, sRow, sCol)
  N = aRow(1)
  ReDim Res(1 To N, 1 To sCol + 1)
  tMax = 100:  k = 1
  For i = 1 To N
    Tong = 0
    For j = 1 To sCol
      iR = ((i - 1) Mod aRow(j)) \ aRow(j + 1) + 1 'Thu tu dong du lieu
      Res(k, j) = sArr(iR, j)
      Tong = Tong + Res(k, j)
    Next j
    If Tong = tMax Then Res(k, j) = Tong
    If Tong <= tMax Then k = k + 1
  Next i
  Range("G2:L1000000").ClearContents
  If k > 1 Then Range("G2").Resize(k - 1, sCol + 1) = Res
End Sub

Private Sub CreateArrDaTa(sArr, aRow, sRow, sCol)
  Dim j&, i&, k&
  aRow(sCol + 1) = 1
  For j = sCol To 1 Step -1
    k = 0
    For i = 1 To sRow
      tmp = sArr(i, j)
      If Len(tmp) Then
        sArr(i, j) = Empty
        k = k + 1:    sArr(k, j) = tmp
      End If
    Next i
    aRow(j) = aRow(j + 1) * k
  Next j
End Sub
 

File đính kèm

  • Book1 (3).xlsm
    18.7 KB · Đọc: 16
Upvote 0
mình có bài toán liên quan đến mảng này mọi người chỉ giúp
1573652261665.png
mình đã lập được mảng colHoanVi gồm 10 phần tử như hình sau:
1573652700809.png
phần tử đầu tiên là 1 mảng gồm 36 phần tử, mỗi phần tử là tập hợp 3 số hạng có tổng là 7
Câu hỏi đặt ra là:
1573652992043.png

duyệt qua các phần tử của mảng colHoanVi(a)(b)(c) như nào để tìm các nghiệm thỏa mãn tổng MT mỗi cột từ 1 đến 3 đều nhỏ hơn 25, tổng CBM mỗi cột 1 đến 3 nhỏ hơn 2.8
 

File đính kèm

  • 1573651898482.png
    1573651898482.png
    10.8 KB · Đọc: 5
  • ToHop.xlsx
    14.5 KB · Đọc: 8
Upvote 0
vanmanhvcu đã viết:
mình có bài toán liên quan đến mảng này mọi người chỉ giúp
View attachment 228303
mình đã lập được mảng colHoanVi gồm 10 phần tử như hình sau:
View attachment 228304
phần tử đầu tiên là 1 mảng gồm 36 phần tử, mỗi phần tử là tập hợp 3 số hạng có tổng là 7
Câu hỏi đặt ra là:
View attachment 228305

duyệt qua các phần tử của mảng colHoanVi(a)(b)(c) như nào để tìm các nghiệm thỏa mãn tổng MT mỗi cột từ 1 đến 3 đều nhỏ hơn 25, tổng CBM mỗi cột 1 đến 3 nhỏ hơn 2.8
Nhấp chuột vào đây để mở rộng...
Bạn tham khảo bài #7 tại địa chỉ: https://www.giaiphapexcel.com/diend...liệu-nhiều-dòng-nhiều-cột.146064/#post-943790
Với bài nầy không cần vét cạn tốn thời gian, chỉ cần đoán và thu hẹp phạm vi nghiệm để tăng tốc xử lý
Mã: 
Sub ABC()
  Dim sArr(), Arr(), aDKien(), Res(), aGHan
  Dim sRow&, N&, i&, q&, j&, m&
  aGHan = Array(0, 25, 2.8) 'Gioi Han dieu kien
  sArr = Range("B4:E13").Value
  sRow = UBound(sArr)
  ReDim Arr(1 To sRow + 1, 1 To 3)
  Arr(sRow + 1, 3) = 1
  For i = sRow To 1 Step -1
    Arr(i, 3) = Arr(i + 1, 3) * 3
    Arr(i, 2) = Round(sArr(i, 4) / 3, 0)
    Arr(i, 1) = sArr(i, 4) - Arr(i, 2) * 2
  Next i
  N = Arr(1, 3)
  For q = 1 To N
    ReDim aDKien(1 To 2, 1 To 3) 'Mang xet dieu kien
    ReDim Res(1 To sRow, 1 To 3) 'Ket qua
    For i = 1 To sRow
      jcol = ((q - 1) Mod Arr(i, 3)) \ Arr(i + 1, 3) + 1 'Thu tu dong du lieu
      Res(i, jcol) = Arr(i, 1)
      For j = 1 To 3
        If j = jcol Then Res(i, j) = Arr(i, 1) Else Res(i, j) = Arr(i, 2)
        For m = 1 To 2
          aDKien(m, j) = aDKien(m, j) + Res(i, j) * sArr(i, m)
          If aDKien(m, j) > aGHan(m) Then GoTo TroLai
        Next m
      Next j
    Next i
    Range("F4").Resize(sRow, 3) = Res
    Exit Sub
TroLai:
  Next q
  Range("F4:H13").ClearContents
  MsgBox ("Can viet Sub Vet Can, phuc tap va chay lau hon")
End Sub
 

File đính kèm

  • ToHop.xlsm
    22.4 KB · Đọc: 13
Upvote 0
HieuCD đã viết:
Bạn tham khảo bài #7 tại địa chỉ: https://www.giaiphapexcel.com/diendan/threads/function-tạo-tổ-hợp-n-phần-tử-từ-mảng-dữ-liệu-nhiều-dòng-nhiều-cột.146064/#post-943790
Với bài nầy không cần vét cạn tốn thời gian, chỉ cần đoán và thu hẹp phạm vi nghiệm để tăng tốc xử lý
Mã: 
Sub ABC()
  Dim sArr(), Arr(), aDKien(), Res(), aGHan
  Dim sRow&, N&, i&, q&, j&, m&
  aGHan = Array(0, 25, 2.8) 'Gioi Han dieu kien
  sArr = Range("B4:E13").Value
  sRow = UBound(sArr)
  ReDim Arr(1 To sRow + 1, 1 To 3)
  Arr(sRow + 1, 3) = 1
  For i = sRow To 1 Step -1
    Arr(i, 3) = Arr(i + 1, 3) * 3
    Arr(i, 2) = Round(sArr(i, 4) / 3, 0)
    Arr(i, 1) = sArr(i, 4) - Arr(i, 2) * 2
  Next i
  N = Arr(1, 3)
  For q = 1 To N
    ReDim aDKien(1 To 2, 1 To 3) 'Mang xet dieu kien
    ReDim Res(1 To sRow, 1 To 3) 'Ket qua
    For i = 1 To sRow
      jcol = ((q - 1) Mod Arr(i, 3)) \ Arr(i + 1, 3) + 1 'Thu tu dong du lieu
      Res(i, jcol) = Arr(i, 1)
      For j = 1 To 3
        If j = jcol Then Res(i, j) = Arr(i, 1) Else Res(i, j) = Arr(i, 2)
        For m = 1 To 2
          aDKien(m, j) = aDKien(m, j) + Res(i, j) * sArr(i, m)
          If aDKien(m, j) > aGHan(m) Then GoTo TroLai
        Next m
      Next j
    Next i
    Range("F4").Resize(sRow, 3) = Res
    Exit Sub
TroLai:
  Next q
  Range("F4:H13").ClearContents
  MsgBox ("Can viet Sub Vet Can, phuc tap va chay lau hon")
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn bác
Nhưng nếu giải theo phần hỏi phía trên của mình với mảng colHoanVi có dạng mảng colHoanVi(x1)(x2)(x3) thì sẽ làm thế nào? Mình chưa biết cách tạo tổ hợp các nghiệm để tìm ra nghiệm nào có tổng các giá trị khác 0 là ít nhất
Dựa theo phương pháp mà bác HieuCD đã từng viết trong topic nào đó
Mã: 
            For i = 0 To colThuTu - 1
                TongMT = 0
                TongCBM = 0
                For j = 0 To UBound(exam)
                    TongMT += tRow(j, 0) * ColHoanVi(j)(tArr(0, j))(i)
                    If TongMT > 25.1 Then GoTo thoat
                    TongCBM += tRow(j, 1) * ColHoanVi(j)(tArr(0, j))(i)
                    If TongCBM > 2.8 Then GoTo thoat
                Next j

            Next i
 
Lần chỉnh sửa cuối:
Upvote 0
vanmanhvcu đã viết:
Cám ơn bác
Nhưng nếu giải theo phần hỏi phía trên của mình với mảng colHoanVi có dạng mảng colHoanVi(x1)(x2)(x3) thì sẽ làm thế nào? Mình chưa biết cách tạo tổ hợp các nghiệm để tìm ra nghiệm nào có tổng các giá trị khác 0 là ít nhất
Dựa theo phương pháp mà bác HieuCD đã từng viết trong topic nào đó
Mã: 
            For i = 0 To colThuTu - 1
                TongMT = 0
                TongCBM = 0
                For j = 0 To UBound(exam)
                    TongMT += tRow(j, 0) * ColHoanVi(j)(tArr(0, j))(i)
                    If TongMT > 25.1 Then GoTo thoat
                    TongCBM += tRow(j, 1) * ColHoanVi(j)(tArr(0, j))(i)
                    If TongCBM > 2.8 Then GoTo thoat
                Next j

            Next i
Nhấp chuột vào đây để mở rộng...
Bạn tạo 1 mảng sArr gồm 10 cột (ứng với 10 dòng) với số dòng là hoán vị cao nhất( hình như là 36)
Chạy từng dòng lấy hoán vị 3 số thỏa mãn tổng như bạn đã làm và gán vào từng cột tương ứng, dòng 1 gán cột 1, dòng 2 gán cột 2. Để nhẹ bộ nhớ có thể chỉ gán số thứ tự
Dùng Function để lấy các mảng các tổ hợp của 10 dòng
Mang = CreateToHop( sArr , True)
Mỗi dòng của mảng là 1 phương án
Hy vọng máy tính đủ bộ nhớ
Mã: 
Function CreateToHop(ByVal sArr As Variant, Optional ByVal bNotBlank = False) As Variant
'CreateToHop: Liet ke to hop N phan tu cua "Mang" 2 chieu "sArr"
'sArr: Là Array hoac Range, neu khac se tra ve "Empty"
'bNotBlank: Là giá tri luan ly, mac dinh = False lay ca gia tri "Empty"
'bNotBlank = True: Loai bo gia tri "Empty", neu có Cot chi co gia tri "Empty", Function tra ve "Empty"
  Dim aRow(), Res(), sCol&, sRow&, N As Double, i As Double, j&, iR&, tmp

  On Error Resume Next
  If TypeName(sArr) = "Range" Then
    If sArr.Count = 1 Then
      tmp = sArr.Value
      ReDim sArr(1 To 1, 1 To 1)
      sArr(1, 1) = tmp
    Else
      sArr = sArr.Value
    End If
  End If
  sRow = UBound(sArr, 1):   sCol = UBound(sArr, 2)
  If Err.Number > 0 Then Exit Function

  Call AddValue_aRow(sArr, aRow, sRow, sCol, bNotBlank)
  N = aRow(1)
  If N = 0 Then Exit Function
  ReDim Res(1 To N, 1 To sCol)
  For i = 1 To N
    For j = 1 To sCol
      iR = ((i - 1) Mod aRow(j)) \ aRow(j + 1) + 1 'Thu tu dong du lieu
      If sArr(iR, j) = Empty Then Res(i, j) = "" Else Res(i, j) = sArr(iR, j)
    Next j
  Next i
  CreateToHop = Res
End Function

Private Sub AddValue_aRow(sArr, aRow, sRow, sCol, bNotBlank)
  Dim i&, j&, k&, tmp
  ReDim aRow(1 To sCol + 1)
  aRow(sCol + 1) = 1
  If bNotBlank = False Then
    For j = sCol To 1 Step -1
      aRow(j) = sRow * aRow(j + 1)
    Next j
  Else
    For j = sCol To 1 Step -1
      k = 0
      For i = 1 To sRow
        tmp = sArr(i, j)
        If Len(tmp) Then
          sArr(i, j) = Empty
          k = k + 1
          sArr(k, j) = tmp
        End If
      Next i
      If k > 0 Then aRow(j) = k * aRow(j + 1)
    Next j
  End If
End Sub
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

ongke0711
  • Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
11 12 13
Trả lời
257
Đọc
25K
Pham Ha 233
Pham Ha 233
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
2
Đọc
97
dung09031989
dung09031989
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
2
Đọc
103
cherry0187
C
N
Vẽ biểu đồ kết hợp nhiều yếu tố trong excel
Trả lời
4
Đọc
112
Ny Ny 2024
N
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
17
Đọc
314
phutdm
P
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
251
Đọc
13K
ongke0711
ongke0711
N
Định mức nguyên vật liệu
Trả lời
1
Đọc
154
yeudoi
yeudoi
P
Nhờ giúp đỡ hàm lọc dữ liệu theo tỉnh
Trả lời
7
Đọc
76
Parabol
P
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
Trả lời
1
Đọc
294
PhanTuHuong
PhanTuHuong
20050911
File Excel lỗi ''The file could not be accessed. Try one of the following:.."
Trả lời
3
Đọc
124
20050911
20050911
B
Định dạng condition formatting, đếm hỗn hợp dữ liệu merge và không merge
Trả lời
17
Đọc
199
batista911
B
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
30
Đọc
698
huuthang_bd
huuthang_bd
H
Tính và sắp xếp theo thư tự tăng dần có điều kiệu (có dữ liệu trùng nhau)
Trả lời
1
Đọc
34
bebo021999
B
V
  • Question
Lấy dữ liệu lãi suất từ website Sbv.gov.vn bằng Power Query
Trả lời
1
Đọc
515
Minhhanhsgu
M
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
149
Đọc
95K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
5
Đọc
148
batista911
B
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
Trả lời
9
Đọc
283
ptm0412
ptm0412
T
Tối ưu hóa hàm lấy dữ liệu từ bảng Tổng sang bảng chi tiết
Trả lời
7
Đọc
245
Hoàng Tuấn 868
H
nguyenphuochien166
Cách Vlookup hoặc cách lấy thông tin dữ liệu có dấu mũ lũy thừa?
    • Cười
Trả lời
6
Đọc
127
tigertiger
tigertiger
T
Không đếm dữ liệu rỗng trong PivotTable
Trả lời
8
Đọc
1K
hoangtuaotrang_hp_vn
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom