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

  • Thread starter Thread starter viehoai
  • Ngày gửi Ngày gửi
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

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

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

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

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

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

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

S
Tính trung bình của tháng đầu tiên.
Trả lời
0
Đọc
13
SteveNguyen1991
S
T
  • Question Question
Xin code VBA trả về tên tài khoản theo điều kiện
    • Chấp nhận
Trả lời
8
Đọc
111
ptm0412
ptm0412
likosin
xin cách lọc này với ạ.
Trả lời
4
Đọc
100
ptm0412
ptm0412
OverAC
[Thông báo] Diễn đàn tạm ngừng hoạt động để bảo trì từ 21g thứ Sáu ngày 20/12
    • Thích
    • Cảm ơn
Trả lời
1
Đọc
894
OverAC
OverAC
A
Nhờ xử lý tính toán Số nằm trong chuỗi kí tự
2
Trả lời
20
Đọc
529
SteveNguyen1991
S
V
  • Question Question
FILE EXCEL LOI : WE FOUND A PROBLEM ... RECOVER
Trả lời
0
Đọc
54
vuasutu08
V
D
  • Question Question
Gửi Email chào giá hàng loạt cho đối tác có nhúng 1 bảng báo giá vào mail
Trả lời
3
Đọc
174
BuiQuangThuan
B
likosin
Nhờ các bác hướng dẫn ạ.
Trả lời
1
Đọc
76
yaaasoo01
Y
C
Lỗi hàm days360
Trả lời
9
Đọc
171
HieuCD
H
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
13 14 15
Trả lời
294
Đọc
19K
ongke0711
ongke0711
HeSanbi
  • Đã giải quyết
HÀM FITROW - Co giãn dòng tự động tối ưu nhất cho Excel v2.43 (*14/10/2024)
    • Thích
    • Yêu thích
2 3
Trả lời
50
Đọc
22K
HeSanbi
HeSanbi
Huy@@*
Xử lý sổ NKC - Gộp nợ có thành 1 dòng
Trả lời
5
Đọc
184
DeTong
D
H
Hướng dẫn in hàng loạt trong excel
Trả lời
16
Đọc
1K
dinhthang8709
D
P
Xin hỏi cách tăng tốc khi nhập liệu cho sheet NHAPXUAT
Trả lời
3
Đọc
152
ptm0412
ptm0412
L
Xin được giúp đỡ DÒ TÌM lấy danh sách tổng giá các đơn hàng
    • Thích
2
Trả lời
26
Đọc
682
LINHCM
L
P
Xin hỏi cách chuyển bảng Hàng + Cột về bảng Hàng + Hàng
Trả lời
2
Đọc
227
pqdowntailieu3
P
aduc
Nhật ký thi công bằng excel
    • Thích
2
Trả lời
35
Đọc
53K
tdhung108
T
M
lỗi khi bấm lọc (Filter) không hiện ra kết quả
Trả lời
1
Đọc
77
thanhduybg92
T
T
cách viết hàm if
Trả lời
3
Đọc
96
HieuCD
H
B
Tạo query tổng hợp dữ liệu
Trả lời
6
Đọc
119
ptm0412
ptm0412
Xem thêm…

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới
Chúc mừng năm mới

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