[trợ giúp] tạo vòng lặp lồng For Next với số vòng lặp phụ thuộc vào người dùng

Liên hệ QC
V

vanmanhvcu

Thành viên chính thức
Tham gia
27/3/11
Bài viết
85
Được thích
10
Chào tất cả mọi người
tôi có 1 vùng trong bảng Excel như ảnh sau:
1551164152008.png

Range(B3:E10) do người dùng nhấp chuột chọn, số lượng ô trong vùng được chọn hiện tại là 32 ô
và tôi muốn viết code VBA tạo số vòng lặp lồng nhau For Next là số lượng ô trong vùng được chọn là 32 để điền giá trị thay đổi từ 1 đến 3 vào các ô đó
vậy có cách nào tạo vòng lặp lồng mà không phải viết thủ công 32 vòng lặp ra hay không?
nếu có cách nào tốt hơn xin mọi người hãy chỉ dẫn giúp !
PHP: 
Sub taoVongLap()
Dim Arr() as integer
Arr()=[B3:E10].value

for Arr(1,1)=1 to 3
    for Arr(1,2)=1 to 3
        for Arr(1,3)=1 to 3
            for Arr(1,4)=1 to 3
                for Arr(2,1)=1 to 3
                    for Arr(2,2)= 1 to 3
                        ..............
                            'tiếp tục đến for Arr(8,4).... thì sẽ rất dài và thủ công
                    next Arr(2,2)
                next Arr(2,1)
            next Arr(1,4)
        next Arr(1,3)
    next Arr(1,2)
next Arr(1,1)

End Sub
 

File đính kèm

  • 1551162367793.png
    1551162367793.png
    7.9 KB · Đọc: 17
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
vanmanhvcu đã viết:
Chào tất cả mọi người
tôi có 1 vùng trong bảng Excel như ảnh sau:
View attachment 212764

Range(B3:E10) do người dùng nhấp chuột chọn, số lượng ô trong vùng được chọn hiện tại là 32 ô
và tôi muốn viết code VBA tạo số vòng lặp lồng nhau For Next là số lượng ô trong vùng được chọn là 32 để điền giá trị thay đổi từ 1 đến 3 vào các ô đó
vậy có cách nào tạo vòng lặp lồng mà không phải viết thủ công 32 vòng lặp ra hay không?
nếu có cách nào tốt hơn xin mọi người hãy chỉ dẫn giúp !
PHP: 
Sub taoVongLap()
Dim Arr() as integer
Arr()=[B3:E10].value

for Arr(1,1)=1 to 3
    for Arr(1,2)=1 to 3
        for Arr(1,3)=1 to 3
            for Arr(1,4)=1 to 3
                for Arr(2,1)=1 to 3
                    for Arr(2,2)= 1 to 3
                        ..............
                            'tiếp tục đến for Arr(8,4).... thì sẽ rất dài và thủ công
                    next Arr(2,2)
                next Arr(2,1)
            next Arr(1,4)
        next Arr(1,3)
    next Arr(1,2)
next Arr(1,1)

End Sub
Nhấp chuột vào đây để mở rộng...
Gửi luôn cái file mềm lên đi bạn
 
Upvote 0
vanmanhvcu đã viết:
Chào tất cả mọi người
tôi có 1 vùng trong bảng Excel như ảnh sau:
View attachment 212764

Range(B3:E10) do người dùng nhấp chuột chọn, số lượng ô trong vùng được chọn hiện tại là 32 ô
và tôi muốn viết code VBA tạo số vòng lặp lồng nhau For Next là số lượng ô trong vùng được chọn là 32 để điền giá trị thay đổi từ 1 đến 3 vào các ô đó
vậy có cách nào tạo vòng lặp lồng mà không phải viết thủ công 32 vòng lặp ra hay không?
nếu có cách nào tốt hơn xin mọi người hãy chỉ dẫn giúp !
PHP: 
Sub taoVongLap()
Dim Arr() as integer
Arr()=[B3:E10].value

for Arr(1,1)=1 to 3
    for Arr(1,2)=1 to 3
        for Arr(1,3)=1 to 3
            for Arr(1,4)=1 to 3
                for Arr(2,1)=1 to 3
                    for Arr(2,2)= 1 to 3
                        ..............
                            'tiếp tục đến for Arr(8,4).... thì sẽ rất dài và thủ công
                    next Arr(2,2)
                next Arr(2,1)
            next Arr(1,4)
        next Arr(1,3)
    next Arr(1,2)
next Arr(1,1)

End Sub
Nhấp chuột vào đây để mở rộng...
Sau khi điền xong bạn muốn thu được kết quả là gì
 
Upvote 0
file của mình đây
1551164198699.png

mình muốn mỗi lần thay đổi giá trị sẽ kiểm tra giá trị tại các ô B13 và H4 xem thỏa mãn điều kiện của mình hay không
ví dụ ô B13 phải thỏa mãn <=7 và ô H4 phải thỏa mãn >=1200.
 

File đính kèm

Upvote 0
vanmanhvcu đã viết:
các điều kiện là cố định hết bạn nhé.
Nhấp chuột vào đây để mở rộng...
điều kiện <=7 có lẽ là khó đạt được.
Bài này có thể dùng solver để giải. Nhìn trong bài cũng đã thấy cài đặt solver nhưng có lẽ do mắc điều kiện trên nên không giải quyết được
Bạn đã chạy thử solver trong file hay chưa?
 
Upvote 0
vòng lặp như vậy nếu chủ thớt thực sự hiểu thì nó là chỉnh hợp đó !

PHP: 
Option Explicit
Dim Arr() as integer

sub Vong_lap(i,j) '----   i-> hàng  , j-> cột
       dim i1 as interger
       dim j1 as interger

       if j<4 then '--------- tăng cột và dòng !
            j1=j+1
       else
            j1=1
            i1=i1+1
       end if

       if i1<=8 then '--------nếu chưa duyệt hết bảng
            for Arr(i,j)=1 to 3
                   '----tính toán gì đó với vòng lặp hiện tại
                   Vong_lap i1,j1    '------- gọi đệ quy ô tiếp theo
            next  Arr(i,j)
       else
            '-----tra ve ket quả
       end if

end sub

Sub taoVongLap()

       Arr()=[B3:E10].value
       Vong_lap 1,1

End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
vanmanhvcu đã viết:
file của mình đây
View attachment 212768

mình muốn mỗi lần thay đổi giá trị sẽ kiểm tra giá trị tại các ô B13 và H4 xem thỏa mãn điều kiện của mình hay không
ví dụ ô B13 phải thỏa mãn <=7 và ô H4 phải thỏa mãn >=1200.
Nhấp chuột vào đây để mở rộng...
Số trường hợp lớn khủng khiếp, cũng may ngay vòng đầu đã có kết quả, nếu không chờ máy chạy mòm mỏi
Mã: 
Sub GPE()
  Dim Rng As Range, tmp(), sArr(), ChayLauQua
  Dim i As Long, j As Long, n As Long
  Dim sRow As Long, sCol As Long, iR As Long, jC As Long
  Set Rng = Range("B3:E10")
  sRow = Rng.Rows.Count
  sCol = Rng.Columns.Count
  ReDim sArr(1 To sRow, 1 To sCol)
  n = sRow * sCol
  ReDim tmp(1 To n)
 
  For i = 1 To n
    tmp(i) = 1
  Next i
  Application.ScreenUpdating = False
  Do While ChayLauQua = Empty
    iR = 1: jC = 0
    For j = 1 To n
      If jC < sCol Then jC = jC + 1 Else jC = 1: iR = iR + 1
      sArr(iR, jC) = tmp(j)
    Next j
    Rng = sArr
    If Range("B13") <= 7 And Range("H4") >= 1200 Then GoTo Thoat
    
    For i = n To 1 Step -1
      If tmp(i) < 3 Then
        tmp(i) = tmp(i) + 1
        For j = i + 1 To n
          tmp(j) = 1
        Next j
        Exit For
      Else
        If i = 1 Then GoTo Thoat
      End If
    Next i
  Loop
Thoat:
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
Số trường hợp lớn khủng khiếp, cũng may ngay vòng đầu đã có kết quả, nếu không chờ máy chạy mòm mỏi
Mã: 
Sub GPE()
  Dim Rng As Range, tmp(), sArr(), ChayLauQua
  Dim i As Long, j As Long, n As Long
  Dim sRow As Long, sCol As Long, iR As Long, jC As Long
  Set Rng = Range("B3:E10")
  sRow = Rng.Rows.Count
  sCol = Rng.Columns.Count
  ReDim sArr(1 To sRow, 1 To sCol)
  n = sRow * sCol
  ReDim tmp(1 To n)

  For i = 1 To n
    tmp(i) = 1
  Next i
  Application.ScreenUpdating = False
  Do While ChayLauQua = Empty
    iR = 1: jC = 0
    For j = 1 To n
      If jC < sCol Then jC = jC + 1 Else jC = 1: iR = iR + 1
      sArr(iR, jC) = tmp(j)
    Next j
    Rng = sArr
    If Range("B13") <= 7 And Range("H4") >= 1200 Then GoTo Thoat
   
    For i = n To 1 Step -1
      If tmp(i) < 3 Then
        tmp(i) = tmp(i) + 1
        For j = i + 1 To n
          tmp(j) = 1
        Next j
        Exit For
      Else
        If i = 1 Then GoTo Thoat
      End If
    Next i
  Loop
Thoat:
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Đọc xong code của bác mới nhớ ra là số âm <= 7 vẫn đủ điều kiện. Vậy mà cứ nghĩ là phải >= 0 o_O
 
Upvote 0
anhtuanle123 đã viết:
vòng lặp như vậy nếu chủ thớt thực sự hiểu thì nó là chỉnh hợp đó !

PHP: 
Option Explicit
Dim Arr() as integer

sub Vong_lap(i,j) '----   i-> hàng  , j-> cột
       dim i1 as interger
       dim j1 as interger

       if j<4 then '--------- tăng cột và dòng !
            j1=j+1
       else
            j1=1
            i1=i1+1
       end if

       if i1<=8 then '--------nếu chưa duyệt hết bảng
            for Arr(i,j)=1 to 3
                   '----tính toán gì đó với vòng lặp hiện tại
                   Vong_lap i1,j1    '------- gọi đệ quy ô tiếp theo
            next  Arr(i,j)
       else
            '-----tra ve ket quả
       end if

end sub

Sub taoVongLap()

       Arr()=[B3:E10].value
       Vong_lap 1,1

End Sub
Nhấp chuột vào đây để mở rộng...
đúng là kiểu chỉnh hợp
Bài đã được tự động gộp:

CHAOQUAY đã viết:
Đọc xong code của bác mới nhớ ra là số âm <= 7 vẫn đủ điều kiện. Vậy mà cứ nghĩ là phải >= 0 o_O
Nhấp chuột vào đây để mở rộng...
nếu có cả điều kiện >=5 và H4 thêm điều kiện<= 1400 thì có vẻ khó nhằn hơn rồi
tôi đang tìm cho cả tình huống này nữa.
Bài đã được tự động gộp:

CHAOQUAY đã viết:
điều kiện <=7 có lẽ là khó đạt được.
Bài này có thể dùng solver để giải. Nhìn trong bài cũng đã thấy cài đặt solver nhưng có lẽ do mắc điều kiện trên nên không giải quyết được
Bạn đã chạy thử solver trong file hay chưa?
Nhấp chuột vào đây để mở rộng...
tôi đã thử bằng solver, nhưng không hiểu giải thuật của nó thế nào
vì nó xây dựng cho bài toán tổng quát
tôi đang chú trọng vào nội dung bài toàn mình để giảm thời gian tính toán.
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Số trường hợp lớn khủng khiếp, cũng may ngay vòng đầu đã có kết quả, nếu không chờ máy chạy mòm mỏi
Mã: 
Sub GPE()
  Dim Rng As Range, tmp(), sArr(), ChayLauQua
  Dim i As Long, j As Long, n As Long
  Dim sRow As Long, sCol As Long, iR As Long, jC As Long
  Set Rng = Range("B3:E10")
  sRow = Rng.Rows.Count
  sCol = Rng.Columns.Count
  ReDim sArr(1 To sRow, 1 To sCol)
  n = sRow * sCol
  ReDim tmp(1 To n)

  For i = 1 To n
    tmp(i) = 1
  Next i
  Application.ScreenUpdating = False
  Do While ChayLauQua = Empty
    iR = 1: jC = 0
    For j = 1 To n
      If jC < sCol Then jC = jC + 1 Else jC = 1: iR = iR + 1
      sArr(iR, jC) = tmp(j)
    Next j
    Rng = sArr
    If Range("B13") <= 7 And Range("H4") >= 1200 Then GoTo Thoat
 
    For i = n To 1 Step -1
      If tmp(i) < 3 Then
        tmp(i) = tmp(i) + 1
        For j = i + 1 To n
          tmp(j) = 1
        Next j
        Exit For
      Else
        If i = 1 Then GoTo Thoat
      End If
    Next i
  Loop
Thoat:
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
xin cám ơn bác, vậy giúp tôi xử lý bài toán gốc như sau nhé
Bài toán đầy đủ như sau:
1551430232696.png

về đáp án thì có thể có nhiều đáp án đáp ứng yêu cầu
và một trong các đáp án đó là:
1551430256032.png

tôi vẫn chưa xây dựng được hoàn thiện thuật toán tìm kết quả
nếu có thể , xin vui lòng tiếp tục giúp đỡ.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
vanmanhvcu đã viết:
xin cám ơn bác, vậy giúp tôi xử lý bài toán gốc như sau nhé
Bài toán đầy đủ như sau:
View attachment 212992

về đáp án thì có thể có nhiều đáp án đáp ứng yêu cầu
và một trong các đáp án đó là:
View attachment 212993

tôi vẫn chưa xây dựng được hoàn thiện thuật toán tìm kết quả
nếu có thể , xin vui lòng tiếp tục giúp đỡ.
Nhấp chuột vào đây để mở rộng...
vanmanhvcu đã viết:
xin cám ơn bác, vậy giúp tôi xử lý bài toán gốc như sau nhé
Bài toán đầy đủ như sau:
View attachment 212992

về đáp án thì có thể có nhiều đáp án đáp ứng yêu cầu
và một trong các đáp án đó là:
View attachment 212993

tôi vẫn chưa xây dựng được hoàn thiện thuật toán tìm kết quả
nếu có thể , xin vui lòng tiếp tục giúp đỡ.
Nhấp chuột vào đây để mở rộng...
Viết code, nhưng không dám chạy thử
Thuật toán vét cạn, cần máy tính cực mạnh
Mã: 
Sub GPE()
  Dim Rng As Range, sArr(), dkRow As Range, dkCol As Range
  Dim dkR1(), dkR2(), dkC1, dkC2, dk As Boolean
  Dim i As Long, j As Long, n As Long, ChayLauQua
  Dim sRow As Long, sCol As Long, iR As Long, jC As Long
 
  Application.ScreenUpdating = False
  Set dkRow = Range("H5:H11")
  dkR1 = Range("F5:F11").Value:  dkR2 = Range("J5:J11").Value
  Set dkCol = Range("B14:E14")
  dkC1 = 4:  dkC2 = 7
  Set Rng = Range("B5:E11")
  sRow = Rng.Rows.Count
  sCol = Rng.Columns.Count
  Rng.Value = 0
  sArr = Rng.Value
  n = sRow * sCol
  Do While ChayLauQua = Empty
    Rng = sArr
    dk = True
    For i = 1 To sRow
      If dkR1(i, 1) > dkRow(i, 1) Then
        dk = False: Exit For
      ElseIf dkR2(i, 1) < dkRow(i, 1) Then
        dk = False: Exit For
      End If
    Next i
    If dk = True Then
      For j = 1 To sCol
        If dkC1 > dkCol(1, j) Then
          dk = False: Exit For
        ElseIf dkC2 < dkCol(1, j) Then
          dk = False: Exit For
        End If
      Next j
    End If
    If dk = True Then GoTo Thoat
    For i = n To 1 Step -1
      iR = Int((i - 1) / sCol) + 1
      jC = ((i - 1) Mod sCol) + 1
      If sArr(iR, jC) < 3 Then
        sArr(iR, jC) = sArr(iR, jC) + 1
        For j = i + 1 To n
          sArr(Int((j - 1) / sCol) + 1, ((j - 1) Mod sCol) + 1) = 0
        Next j
        Exit For
      Else
        If i = 1 Then GoTo Thoat
      End If
    Next i
  Loop
Thoat:
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
Viết code, nhưng không dám chạy thử
Thuật toán vét cạn, cần máy tính cực mạnh
Mã: 
Sub GPE()
  Dim Rng As Range, sArr(), dkRow As Range, dkCol As Range
  Dim dkR1(), dkR2(), dkC1, dkC2, dk As Boolean
  Dim i As Long, j As Long, n As Long, ChayLauQua
  Dim sRow As Long, sCol As Long, iR As Long, jC As Long

  Application.ScreenUpdating = False
  Set dkRow = Range("H5:H11")
  dkR1 = Range("F5:F11").Value:  dkR2 = Range("J5:J11").Value
  Set dkCol = Range("B14:E14")
  dkC1 = 4:  dkC2 = 7
  Set Rng = Range("B5:E11")
  sRow = Rng.Rows.Count
  sCol = Rng.Columns.Count
  Rng.Value = 0
  sArr = Rng.Value
  n = sRow * sCol
  Do While ChayLauQua = Empty
    Rng = sArr
    dk = True
    For i = 1 To sRow
      If dkR1(i, 1) > dkRow(i, 1) Then
        dk = False: Exit For
      ElseIf dkR2(i, 1) < dkRow(i, 1) Then
        dk = False: Exit For
      End If
    Next i
    If dk = True Then
      For j = 1 To sCol
        If dkC1 > dkCol(1, j) Then
          dk = False: Exit For
        ElseIf dkC2 < dkCol(1, j) Then
          dk = False: Exit For
        End If
      Next j
    End If
    If dk = True Then GoTo Thoat
    For i = n To 1 Step -1
      iR = Int((i - 1) / sCol) + 1
      jC = ((i - 1) Mod sCol) + 1
      If sArr(iR, jC) < 3 Then
        sArr(iR, jC) = sArr(iR, jC) + 1
        For j = i + 1 To n
          sArr(Int((j - 1) / sCol) + 1, ((j - 1) Mod sCol) + 1) = 0
        Next j
        Exit For
      Else
        If i = 1 Then GoTo Thoat
      End If
    Next i
  Loop
Thoat:
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
cám ơn bác, quan trọng là tìm được thuật toán tốt. tôi sẽ thử
 
Upvote 0
@vanmanhvcu
@HieuCD
Đoạn code này chỉ tìm thấy 4 tổ hợp đạt yêu cầu, không biết liệu còn có tổ hợp nào khác hay không.
Bạn tạo thêm sheet mới, đặt tên là sheet1 rồi chạy code. Kết quả mỗi 1 cột là 1 tổ hợp
Mã: 
Option Explicit
Sub BaiToan()
Dim CotA
Dim BE2, BE3, BE4
Dim YCau, YCau12, YCau085
Dim MinSL, MaxSL
Dim Tich, Cong
Dim ToHop, Th
Dim Tam
Dim Kq
Dim DicTT As Object
Dim i, j, k, x, z, t, w, v, y, a, Tm
Tm = Timer
Set DicTT = CreateObject("Scripting.Dictionary")
With Sheet2
    CotA = .Range("a5:a11")
    BE2 = .Range("b2:e2")
    BE3 = .Range("b3:e3")
    BE4 = .Range("b4:e4")
    YCau = .Range("k5:k11")
    YCau12 = .Range("j5:j11")
    YCau085 = .Range("f5:f11")
    MinSL = 4
    MaxSL = 7
End With
ReDim Tam(1 To 4 ^ 4)
ReDim Th(3)
z = 0
For i = 0 To 3
    Th(0) = i
    For j = 0 To 3
        Th(1) = j
        For k = 0 To 3
            Th(2) = k
            For x = 0 To 3
                Th(3) = x
                z = z + 1
                Tam(z) = Th
            Next x
        Next k
    Next j
Next i
ReDim Tich(1 To 4)
For j = 1 To 4
    Tich(j) = BE2(1, j) * BE4(1, j) / BE3(1, j)
Next j
ReDim ToHop(1 To 7, 1 To 1)
For i = 1 To 7
    DicTT.RemoveAll
    z = 0
    For Each Th In Tam
        Cong = 0
        For j = 0 To 3
            Cong = Cong + Tich(j + 1) * Th(j)
        Next j
        Cong = Cong * CotA(i, 1)
        If Cong >= YCau085(i, 1) And Cong <= YCau12(i, 1) Then
            z = z + 1
            DicTT.Add z, Th
        End If
    Next Th
    ToHop(i, 1) = DicTT.Items
Next i
DicTT.RemoveAll
ReDim Cong(3)
For Each i In ToHop(1, 1)
    For Each j In ToHop(2, 1)
        For Each k In ToHop(3, 1)
            For Each x In ToHop(4, 1)
                For Each z In ToHop(5, 1)
                    For Each t In ToHop(6, 1)
                        For Each y In ToHop(7, 1)
                            v = 0
                            For w = 0 To 3
                                Cong(w) = 0
                                Cong(w) = i(w) * CotA(1, 1) + j(w) * CotA(2, 1) + k(w) * CotA(3, 1) _
                                + x(w) * CotA(4, 1) + z(w) * CotA(5, 1) + t(w) * CotA(6, 1) + y(w) * CotA(7, 1)
                               
                                Cong(w) = BE3(1, w + 1) - Cong(w)
                                If Cong(w) > MaxSL Or Cong(w) < MinSL Then
                                    Exit For
                                Else
                                    v = v + 1
                                End If
                            Next w
                            If v = 4 Then
                                a = a + 1
                                DicTT.Add a, Array(i, j, k, x, z, t, y)
                            End If
                        Next y
                    Next t
                Next z
            Next x
        Next k
    Next j
Next i
ReDim Kq(1 To 7, 1 To DicTT.Count)
i = 0
For Each Th In DicTT.Items
    i = i + 1
    For j = 0 To 6
        Kq(j + 1, i) = Join(Th(j))
    Next j
Next Th
With Sheets("Sheet1")
.UsedRange.ClearContents
.Range("A3") = DicTT.Count
.Range("A6").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
.Range("A1") = Timer - Tm
End With
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
vanmanhvcu đã viết:
cám ơn bác, quan trọng là tìm được thuật toán tốt. tôi sẽ thử
Nhấp chuột vào đây để mở rộng...
Dùng thuật toán vét cạn 2 bước, xét điều kiện cột sau đó xét điều kiện dòng
Mã: 
  Dim Arr() As Long, jArr(), colArr(), cArr() As Long
  Dim tRow(), tCol(), dkR1(), dkR2(), dkC1, dkC2
  Dim M As Long, N As Long, Tong, tmp
  Dim i As Long, j As Long, c As Long, k As Long
  Dim sRow As Long, sCol As Long

Sub GPE()
  dkR1 = Range("F5:F11").Value:  dkR2 = Range("J5:J11").Value
  tRow = Range("B2:E4").Value
  sRow = UBound(dkR1, 1):  sCol = UBound(tRow, 2)
  For j = 1 To sCol
    tRow(1, j) = tRow(1, j) * tRow(3, j) / tRow(2, j)
  Next j
  tCol = Range("A5:A11").Value
  dkC1 = 4:  dkC2 = 7:  N = 4
  Call ChinhHop
  Call AddCol
  Range("M5", Range("P1000000").End(xlUp)).ClearContents
  Call KetQua
End Sub

Private Sub ChinhHop()
  M = N ^ sRow
  ReDim cArr(1 To sRow, 1 To M)
  For j = 2 To M
    For i = sRow To 1 Step -1
      If cArr(i, j - 1) < 3 Then
        cArr(i, j) = cArr(i, j - 1) + 1
        For k = i + 1 To sRow
          cArr(k, j) = 0
        Next k
        For k = 1 To i - 1
          cArr(k, j) = cArr(k, j - 1)
        Next k
        Exit For
      End If
    Next i
  Next j
End Sub

Private Sub AddCol()
  ReDim colArr(1 To sCol)
  For j = 1 To sCol
    k = 0
    ReDim jArr(1 To 1)
    For c = 1 To M
      Tong = tRow(2, j)
      ReDim Arr(1 To sRow)
      For i = 1 To sRow
        tmp = cArr(i, c)
        If tmp > 0 Then
          If tRow(1, j) * tCol(i, 1) * tmp > dkR2(i, 1) Then GoTo Thoat
          Tong = Tong - tCol(i, 1) * tmp
          If Tong < dkC1 Then GoTo Thoat
          Arr(i) = tmp
        End If
      Next i
      If Tong <= dkC2 Then
        k = k + 1
        ReDim Preserve jArr(1 To k)
        jArr(k) = Arr
      End If
Thoat:
    Next c
    colArr(j) = jArr
  Next j
  Erase cArr
End Sub

Private Sub KetQua()
  Dim Arr1(), Arr2(), Arr3(), Arr4()
  Dim j1 As Long, j2 As Long, j3 As Long, j4 As Long
 
  ReDim Arr(1 To sRow, 1 To sCol)
  Arr1 = colArr(1): Arr2 = colArr(2)
  Arr3 = colArr(3): Arr4 = colArr(4)
  k = 0
  For j1 = 1 To UBound(Arr1)
    For j2 = 1 To UBound(Arr2)
      For j3 = 1 To UBound(Arr3)
        For j4 = 1 To UBound(Arr4)
          For i = 1 To sRow
            Tong = tCol(i, 1) * (tRow(1, 1) * Arr1(j1)(i) + tRow(1, 2) * Arr2(j2)(i) + tRow(1, 3) * Arr3(j3)(i) + tRow(1, 4) * Arr4(j4)(i))
            If Tong <= dkR1(i, 1) Or Tong >= dkR2(i, 1) Then GoTo Thoat
            Arr(i, 1) = Arr1(j1)(i): Arr(i, 2) = Arr2(j2)(i)
            Arr(i, 3) = Arr3(j3)(i): Arr(i, 4) = Arr4(j4)(i)
          Next i
          k = k + 1
          Range("M" & (sRow + 1) * (k - 1) + 5).Resize(sRow, sCol) = Arr
Thoat:
        Next
      Next
    Next
  Next
End Sub
 

File đính kèm

Upvote 0
Tôi thấy cứ ngờ ngợ, muốn hỏi chủ topic cái này ứng dụng vào gì? mà sao phải xét nhiều vậy, có thể dùng Solver, hoặc quy hoạch động có thể gần sát với vấn đề này hơn.
 
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

dinhnhat91
  • Question Question
VBA Lỗi runtime error 9 subscript out of range
Trả lời
4
Đọc
70
ongke0711
ongke0711
GPE-Trợ Lý
[GPE] TALK SHOW EXCEL TRONG SẢN XUẤT
    • Thích
Trả lời
1
Đọc
508
PhanTuHuong
PhanTuHuong
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
0
Đọc
49
Việt Nguyễn 86
Việt Nguyễn 86
K
Mong giúp dữ liệu từ trang web sang excel
Trả lời
0
Đọc
49
khanhvinhdai1
K
T
Bảng tính trợ cấp tinh giản biên chế theo NĐ 108
    • Thích
Trả lời
3
Đọc
1K
trung_bhxh
T
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
Trả lời
0
Đọc
76
trung_bhxh
T
L
Viết phần mềm đánh lô bằng Visual Basic
    • Thích
2 3
Trả lời
52
Đọc
103K
khanhvinhdai1
K
GPE-Trợ Lý
KHÓA HỌC BỨT PHÁ KỸ NĂNG EXCEL
    • Thích
    • Yêu thích
Trả lời
3
Đọc
1K
Skyler113
Skyler113
Mewwo98
Thay dấu ngăn cách sau chữ số hàng nghìn, hàng triệu, hàng tỷ trong Mail Merge
Trả lời
5
Đọc
108
ptm0412
ptm0412
Huyen9
Lỗi không mailings được.
Trả lời
3
Đọc
84
vanle33
vanle33
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
14 15 16
Trả lời
310
Đọc
23K
kunkoi9390
K
K
Có ai giúp mình lấy kết quả xổ số miền nam về file excel
Trả lời
0
Đọc
43
khanhvinhdai1
K
ptm0412
  • Question Question
Lấy dữ liệu web nhiều trang về file Excel bằng Power Query
    • Thích
Trả lời
5
Đọc
2K
ptm0412
ptm0412
H
Công thức tìm kết quả
Trả lời
11
Đọc
124
VetMini
V
V
Hàm dò tìm lấy giá trị của lần xuất hiện thứ n trong excel.
Trả lời
9
Đọc
1K
VetMini
V
N
Nhờ các anh chỉ chỉnh lỗi giúp em với ạ, em cảm ơn ạ.
Trả lời
3
Đọc
82
minhminh27
minhminh27
T
File quản lý thiết bị trong trường học!
Trả lời
4
Đọc
139
VetMini
V
Xoainon3005
Xin file mẫu kế hoạch sản xuất theo tháng ngành động cơ
Trả lời
1
Đọc
134
VetMini
V
Momominh
Sơ đồ hàng hóa trong Container
Trả lời
3
Đọc
135
VetMini
V
hungtin1997
  • Question Question
[Hỏi] Tạo Hyperlink đến ô chạy ngang theo cột
Trả lời
6
Đọc
420
A HOANG 620
A
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

Đế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 Ất Tỵ 2025
Back
Top Bottom