[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 (1 người xem)

vanmanhvcu · 26/2/19

Chào tất cả mọi người
tôi có 1 vùng trong bảng Excel như ảnh sau:

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

Lê Hồng Minh83 · 26/2/19

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

Gửi luôn cái file mềm lên đi bạn

CHAOQUAY · 26/2/19

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

Sau khi điền xong bạn muốn thu được kết quả là gì

vanmanhvcu · 26/2/19

file của mình đây

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.

CHAOQUAY · 26/2/19

H5:H10; C13:E13 thì sao?

vanmanhvcu · 26/2/19

CHAOQUAY đã viết:
H5:H10; C13:E13 thì sao?

các ô bôi vàng cũng như vậy
mình hỏi cho 2 ô B13 và H4 nếu xử lý được thì các ô đó sẽ tương tự
vì vậy rút gọn cho đỡ rối mắt thôi.

CHAOQUAY · 26/2/19

vanmanhvcu đã viết:
các ô bôi vàng cũng như vậy
mình hỏi cho 2 ô B13 và H4 nếu xử lý được thì các ô đó sẽ tương tự
vì vậy rút gọn cho đỡ rối mắt thôi.

Điều kiện <=7, >=1200 & 1<=B3:E10<=3 là cố đinh hay không ban.

vanmanhvcu · 26/2/19

CHAOQUAY đã viết:
Điều kiện <=7, >=1200 & 1<=B3:E10<=3 là cố đinh hay không ban.

các điều kiện là cố định hết bạn nhé.

CHAOQUAY · 26/2/19

vanmanhvcu đã viết:
các điều kiện là cố định hết bạn nhé.

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

anhtuanle123 · 26/2/19

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

HieuCD · 27/2/19

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.

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

CHAOQUAY · 27/2/19

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

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

vanmanhvcu · 27/2/19

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

đúng là kiểu chỉnh hợp

Bài đã được tự động gộp: 27/2/19

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

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: 27/2/19

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?

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.

vanmanhvcu · 1/3/19

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

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:

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

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 đỡ.

HieuCD · 1/3/19

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 đỡ.

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

vanmanhvcu · 1/3/19

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

cám ơn bác, quan trọng là tìm được thuật toán tốt. tôi sẽ thử

CHAOQUAY · 1/3/19

@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

anhtuanle123 · 1/3/19

góp vui luôn ,
mình cũng quét thử ra được 4 kết quả !
nghiên cứu 1 hồi tìm được quy luật , nên tránh được vét cạn ,
tốc độ là 1 giây !@@

HieuCD · 2/3/19

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ử

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

tam888 · 2/3/19

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.

vanmanhvcu · 2/3/19

tam888 đã viết:
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.

Ứng dụng vào hoạt động sản xuất thôi bác @tam888
Tên topic và nơi mà tôi post bài viết là trong chủ đề "Lập trình với Excel" đã nói lên mục đích đó là dùng giải thuật lập trình để tìm đáp án cho bài toán.
Nếu dùng Solver thì chúng ta không thể hiểu được giải thuật của nó là gì
Có thể bác không để ý, trong #13 tôi đã nói là đã thử bằng Solver và tôi thấy rằng Solver có nhược điểm là chỉ tìm ra 1 đáp án duy nhất.
và xin cảm ơn tới @HieuCD @anhtuanle123 @CHAOQUAY đã cho tôi mở mang hơn.
nói thật, tôi vẫn đang phải nghiên cứu để cố gắng hiểu hết dòng code đó với hiểu biết hạn hẹp của mình.

excel_lv1.5 · 2/3/19

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 đỡ.

Góp vui, cho bạn thêm code có thể tùy biến khi thêm dòng hoặc cột thay đổi vùng điều kiện là được, code dùng thuật toán so sánh chuỗi 2 điều kiện để loại bỏ nhiều nhất các trường hợp không đúng.

anhtuanle123 · 2/3/19

kiểu dữ liệu giằng co hàng cột kiểu này chắc là tham số cho 1 hàm tính nào đó , như tính mức tối ưu giữa chi phí và lợi nhuận , hoặc trong xây dựng là tính điểm chịu lực tối ưu chẳng hạn , miềng đoán thế ^^!

mình chia sẻ với bác chủ thớt cách mình và 1 số bạn đi theo để giảm thời gian tính toán là thay vì xét cả thảy 28 ô 1 lúc , tức là 28 vòng for , với mỗi vòng 0->3 , tức là 4 giá trị , tương đương 4^28 bước lặp = 72057594037927936 vòng lặp ( con số này chắc phải có 1 siêu máy tính mới tính nổi ) ,
sau khi nghiên cứu công thức của bác , thì thấy rằng thực ra dữ liệu cột này cũng ko liên quan đến cột kia , nên ta đưa về bài toán tính chỉnh hợp trên từng cột 7 ô , tức là 4^7=16384 lần lặp cho 1 cột ,
ta tính 4 cột thì bằng 16384 * 4 = 65536 bước lặp là có thể tìm ra kết quả cho 4 cột !
trong quá trình test thử mình thấy rằng cột có số trường hợp thỏa mãn cho chính cột đó có khoảng 20 trường hợp , cứ cho mỗi cột có 20 là tối đa đi , thì tìm chỉnh hợp theo kết quả cột 20 ^ 4 = 160000 lần lặp nữa là tìm được kết quả cho bảng tính !
nói chung bác cứ tính thử cho 1 cột là sẽ ngộ ra bài toán !
tặng bác cuốn bí kíp để luyện công ^^
book

excel_lv1.5 · 3/3/19

anhtuanle123 đã viết:
kiểu dữ liệu giằng co hàng cột kiểu này chắc là tham số cho 1 hàm tính nào đó , như tính mức tối ưu giữa chi phí và lợi nhuận , hoặc trong xây dựng là tính điểm chịu lực tối ưu chẳng hạn , miềng đoán thế ^^!

mình chia sẻ với bác chủ thớt cách mình và 1 số bạn đi theo để giảm thời gian tính toán là thay vì xét cả thảy 28 ô 1 lúc , tức là 28 vòng for , với mỗi vòng 0->3 , tức là 4 giá trị , tương đương 4^28 bước lặp = 72057594037927936 vòng lặp ( con số này chắc phải có 1 siêu máy tính mới tính nổi ) ,
sau khi nghiên cứu công thức của bác , thì thấy rằng thực ra dữ liệu cột này cũng ko liên quan đến cột kia , nên ta đưa về bài toán tính chỉnh hợp trên từng cột 7 ô , tức là 4^7=16384 lần lặp cho 1 cột ,
ta tính 4 cột thì bằng 16384 * 4 = 65536 bước lặp là có thể tìm ra kết quả cho 4 cột !
trong quá trình test thử mình thấy rằng cột có số trường hợp thỏa mãn cho chính cột đó có khoảng 20 trường hợp , cứ cho mỗi cột có 20 là tối đa đi , thì tìm chỉnh hợp theo kết quả cột 20 ^ 4 = 160000 lần lặp nữa là tìm được kết quả cho bảng tính !
nói chung bác cứ tính thử cho 1 cột là sẽ ngộ ra bài toán !
tặng bác cuốn bí kíp để luyện công ^^
book

Nếu làm theo bài này thì đúng là nên chạy theo cột là ngon nhất, vì số thỏa mãn cả 4 cột chỉ có hơn 30.000 trường hợp sau đó xét các trường hợp này trên từng dòng là xong. Nhưng nếu đổi lại độ chênh lệch cao (không phải min=4, max=7) hoặc số dòng cột tăng thêm thì sài cột không chưa chắc đã hợp lý, như trong bài này nếu làm theo dòng thì số trường hợp cần chạy lên tới 2 triệu trường hợp, nói chung nếu chỉ chọn hoặc cột hay dòng thì tổng quát chưa tối ưu lắm, mới đầu tôi cũng tính làm theo cột nhưng thấy không ổn lắm, cuối cùng làm tổng quát là cả cột và dòng luôn nhưng xét riêng từng cái, sau đó dùng chuỗi so sanh cả 2 điều kiện này , nên bài này tôi chạy chỉ có 40 trường hợp , nếu xét đủ điều kiện cột , dòng và giao nhau giữa cột và dòng.

anhtuanle123 · 3/3/19

chạy theo cột tuy tưởng là 1 cách giải khác , nhưng thực ra cũng phải chạy qua 28 vòng lặp , bản chất việc chạy 2 bước này là áp dụng nhánh cận lọc ra các trường hợp thỏa theo cột , nhờ đó giảm được việc đi tiếp nếu cột trước chưa thỏa !
thực ra ta vẫn có thể gộp chung vào 1 vòng lặp lớn mà ko cần chia ra 2 bước , nhưng xét điều kiện 7 ô 1 lần , nếu 7 ô trước thỏa thì mới đi tiếp !

CHAOQUAY · 3/3/19

anhtuanle123 đã viết:
chạy theo cột tuy tưởng là 1 cách giải khác , nhưng thực ra cũng phải chạy qua 28 vòng lặp , bản chất việc chạy 2 bước này là áp dụng nhánh cận lọc ra các trường hợp thỏa theo cột , nhờ đó giảm được việc đi tiếp nếu cột trước chưa thỏa !
thực ra ta vẫn có thể gộp chung vào 1 vòng lặp lớn mà ko cần chia ra 2 bước , nhưng xét điều kiện 7 ô 1 lần , nếu 7 ô trước thỏa thì mới đi tiếp !

Thực chất các code trên đều tính theo 2 bước, Cột _ Dòng hoặc Dòng _ Cột. Chỉ khác nhau là cách loại trừ, dẫn đến khối lượng tính thay đổi nên code nhanh hoặc chậm hơn.
Nếu tính trực tiếp trên mảng 4*7 chắc có lẽ phải dùng thuật toán khác

vanmanhvcu · 3/3/19

excel_lv1.5 đã viết:
Nếu làm theo bài này thì đúng là nên chạy theo cột là ngon nhất, vì số thỏa mãn cả 4 cột chỉ có hơn 30.000 trường hợp sau đó xét các trường hợp này trên từng dòng là xong. Nhưng nếu đổi lại độ chênh lệch cao (không phải min=4, max=7) hoặc số dòng cột tăng thêm thì sài cột không chưa chắc đã hợp lý, như trong bài này nếu làm theo dòng thì số trường hợp cần chạy lên tới 2 triệu trường hợp, nói chung nếu chỉ chọn hoặc cột hay dòng thì tổng quát chưa tối ưu lắm, mới đầu tôi cũng tính làm theo cột nhưng thấy không ổn lắm, cuối cùng làm tổng quát là cả cột và dòng luôn nhưng xét riêng từng cái, sau đó dùng chuỗi so sanh cả 2 điều kiện này , nên bài này tôi chạy chỉ có 40 trường hợp , nếu xét đủ điều kiện cột , dòng và giao nhau giữa cột và dòng.

Nếu nói về bài toán tổng quát tôi xin chia sẻ thực tế như sau
1. Độ chênh lệch của tôi luôn luôn fixed trong khoảng (4-7)
2. Số lượng cột luôn luôn < số lượng hàng
3. Số lượng hàng Max là 24 ( rất ít khi có)
4. Giá trị trong vùng tìm kiếm luôn luôn từ 0 đến 4 ( bài toán này chỉ là đến 3)

CHAOQUAY · 3/3/19

@vanmanhvcu
Giả sử với file tổng quát thì bạn có thể áng chừng khoảng bao nhiêu nghiệm?

Kiều Mạnh · 3/3/19

coi bài thớt này thấy mấy bạn dùng từ: thuật toán vét cạn + chỉnh hợp ...
thấy ít người xài quá ... coi tới lui mà ko hiểu cơ bản nó như thế nào là thuật toán vét cạn ??? tại vì có nghe bên ngoài có người nói tới thuật toán vét cạn .... nên cũng đang tò mò chút ???
Tiện đây bạn nào cho 1 VD rất cơ bản + code cơ bản làm sao để người đọc hiểu được đó là thuật toán vét cạn cho Mạnh học với 1 chút
Xin cảm ơn

vanmanhvcu · 3/3/19

CHAOQUAY đã viết:
@vanmanhvcu
Giả sử với file tổng quát thì bạn có thể áng chừng khoảng bao nhiêu nghiệm?

Câu hỏi này hơi khó!

Vì nếu với trường hợp tổng quát, tìm được 1 nghiệm là thành công rồi

anhtuanle123 · 3/3/19

hi bác Mạnh , thực ra thì từ vét cạn ko biết nó có từ bao giờ , chỉ biết trong các tài liệu chính quy thì nó là từ chuẩn được dùng ,
vét : là vơ vét
cạn : là cạn kiệt
chắc ý là vét sạch sành sanh ấy ^^
về ví dụ thì mình xin mạn phép chia sẻ như sau :
ví dụ ta có 1 bài toán như sau , liệt kê các số với 3 chữ số abc , kèm điều kiện là các chữ số trong chuỗi ràng buộc như sau , chữ số 1 là chẵn , số 2 =5 hoặc 7 , số 3 là số lẻ -> vd : 253 , 471
ta có code macro sau !

Mã:

Sub ex()
  
    Dim i, j, k As Integer
    Dim v As String
    Dim m As Integer
    m = 1
  
    Dim count As Integer '-----dem so buoc lap
    count = 0
  
    For i = 0 To 9
        For j = 0 To 9
            For k = 0 To 9
              
                If i Mod 2 = 0 And (j = 5 Or j = 7) And k Mod 2 = 1 Then
              
                    v = "_" & i & j & k 'tinh toan
                    Range("A" & m) = v  '
                    m = m + 1           '
                  
                End If
              
                count = count + 1
              
            Next k
        Next j
    Next i
          
    MsgBox count '-----so buoc xu ly
          
End Sub

ta thấy chạy xong thì chương trình chạy đủ 10^3=10*10*10=1000 vòng lặp

nhưng nếu chặn bên ngoài

Mã:

Sub ex()
   
    Dim i, j, k As Integer
    Dim v As String
    Dim m As Integer
    m = 1
   
    Dim count As Integer '-----dem so buoc lap
    count = 0
   
    For i = 0 To 9
      If i Mod 2 = 0 Then '---1
        For j = 0 To 9
          If j = 5 Or j = 7 Then '----2
            For k = 0 To 9
                If k Mod 2 = 1 Then '----3
               
                    v = "_" & i & j & k 'tinh toan
                    Range("A" & m) = v  '
                    m = m + 1           '
                   
                End If '----3
                count = count + 1
            Next k
          End If '----2
        Next j
      End If  '----1
    Next i
           
    MsgBox count '-----so buoc xu ly
           
End Sub

thì chỉ chạy 100 bước là ra kết quả rùi , tức là vét có chọn lọc ^^!

CHAOQUAY · 3/3/19

vanmanhvcu đã viết:
Câu hỏi này hơi khó!
Vì nếu với trường hợp tổng quát, tìm được 1 nghiệm là thành công rồi

Có lẽ nếu tiện, bạn đính kèm 1 file có mô hình lớn nhất lên thử xem sao.

HieuCD · 3/3/19

anhtuanle123 đã viết:
kiểu dữ liệu giằng co hàng cột kiểu này chắc là tham số cho 1 hàm tính nào đó , như tính mức tối ưu giữa chi phí và lợi nhuận , hoặc trong xây dựng là tính điểm chịu lực tối ưu chẳng hạn , miềng đoán thế ^^!

mình chia sẻ với bác chủ thớt cách mình và 1 số bạn đi theo để giảm thời gian tính toán là thay vì xét cả thảy 28 ô 1 lúc , tức là 28 vòng for , với mỗi vòng 0->3 , tức là 4 giá trị , tương đương 4^28 bước lặp = 72057594037927936 vòng lặp ( con số này chắc phải có 1 siêu máy tính mới tính nổi ) ,
sau khi nghiên cứu công thức của bác , thì thấy rằng thực ra dữ liệu cột này cũng ko liên quan đến cột kia , nên ta đưa về bài toán tính chỉnh hợp trên từng cột 7 ô , tức là 4^7=16384 lần lặp cho 1 cột ,
ta tính 4 cột thì bằng 16384 * 4 = 65536 bước lặp là có thể tìm ra kết quả cho 4 cột !
trong quá trình test thử mình thấy rằng cột có số trường hợp thỏa mãn cho chính cột đó có khoảng 20 trường hợp , cứ cho mỗi cột có 20 là tối đa đi , thì tìm chỉnh hợp theo kết quả cột 20 ^ 4 = 160000 lần lặp nữa là tìm được kết quả cho bảng tính !
nói chung bác cứ tính thử cho 1 cột là sẽ ngộ ra bài toán !
tặng bác cuốn bí kíp để luyện công ^^
book

Nhìn mục lục rất mê, tiếc rằng không đủ sức tiêu hóa nội dung

vanmanhvcu đã viết:
Nếu nói về bài toán tổng quát tôi xin chia sẻ thực tế như sau
1. Độ chênh lệch của tôi luôn luôn fixed trong khoảng (4-7)
2. Số lượng cột luôn luôn < số lượng hàng
3. Số lượng hàng Max là 24 ( rất ít khi có)
4. Giá trị trong vùng tìm kiếm luôn luôn từ 0 đến 4 ( bài toán này chỉ là đến 3)

Thay sub KetQua bằng sub TestRow_Ketqua để chạy số dòng số cột thay đổi, chỉ nhập lại địa chỉ dữ liệu chuẩn
Số dòng tăng sẽ làm code chậm rất nhiều, có thể thiếu bộ nhớ

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 GPE2()
  Tg = Timer
  dkR1 = Range("F5:F11").Value:  dkR2 = Range("J5:J11").Value 'Dieu kien Dong
  tRow = Range("B2:E4").Value 'Tham so dong
  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 'Tham so cot
  dkC1 = 4:  dkC2 = 7 ' Dieu kien Cot
  N = 4 'So gia tri lua chon
  Call ChinhHop
  Call AddCol
  Range("M5", Range("P1000000").End(xlUp)).ClearContents
  Call TestRow_KetQua
  [l2] = Timer - Tg
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
        End If
      Next i
      If Tong <= dkC2 Then
        For i = 1 To sRow
          Arr(i) = cArr(i, c)
        Next i
        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 TestRow_KetQua()
  Dim tArr() As Long, ChayNhanhLen As String
  ReDim Arr(1 To sRow, 1 To sCol)
  ReDim tArr(1 To 2, 1 To sCol)
  For j = 1 To sCol
    tArr(1, j) = 1: tArr(2, j) = UBound(colArr(j))
  Next j
  k = 0
  Do While ChayNhanhLen = Empty
    For i = 1 To sRow
      Tong = 0
      For j = 1 To sCol
        Tong = Tong + tRow(1, j) * colArr(j)(tArr(1, j))(i)
      Next j
      Tong = Tong * tCol(i, 1)
      If Tong < dkR1(i, 1) Or Tong > dkR2(i, 1) Then GoTo Thoat
    Next i
    For i = 1 To sRow
      For j = 1 To sCol
        Arr(i, j) = colArr(j)(tArr(1, j))(i)
      Next j
    Next i
    k = k + 1
    Range("M" & (sRow + 1) * (k - 1) + 5).Resize(sRow, sCol) = Arr
Thoat:
    For j = sCol To 1 Step -1
      If tArr(1, j) < tArr(2, j) Then
        tArr(1, j) = tArr(1, j) + 1
        For i = j + 1 To sCol
          tArr(1, i) = 1
        Next i
        Exit For
      Else
        If j = 1 Then Exit Sub
      End If
    Next j
  Loop
End Sub

concogia · 4/3/19

anhtuanle123 đã viết:
hi bác Mạnh , thực ra thì từ vét cạn ko biết nó có từ bao giờ , chỉ biết trong các tài liệu chính quy thì nó là từ chuẩn được dùng ,
vét : là vơ vét
cạn : là cạn kiệt
chắc ý là vét sạch sành sanh ấy ^^
về ví dụ thì mình xin mạn phép chia sẻ như sau :
ví dụ ta có 1 bài toán như sau , liệt kê các số với 3 chữ số abc , kèm điều kiện là các chữ số trong chuỗi ràng buộc như sau , chữ số 1 là chẵn , số 2 =5 hoặc 7 , số 3 là số lẻ -> vd : 253 , 471
ta có code macro sau !

Mã:

Sub ex() Dim i, j, k As Integer Dim v As String Dim m As Integer m = 1 Dim count As Integer '-----dem so buoc lap count = 0 For i = 0 To 9 For j = 0 To 9 For k = 0 To 9 If i Mod 2 = 0 And (j = 5 Or j = 7) And k Mod 2 = 1 Then v = "_" & i & j & k 'tinh toan Range("A" & m) = v ' m = m + 1 ' End If count = count + 1 Next k Next j Next i MsgBox count '-----so buoc xu ly End Sub

ta thấy chạy xong thì chương trình chạy đủ 10^3=10*10*10=1000 vòng lặp

nhưng nếu chặn bên ngoài

Mã:

Sub ex() Dim i, j, k As Integer Dim v As String Dim m As Integer m = 1 Dim count As Integer '-----dem so buoc lap count = 0 For i = 0 To 9 If i Mod 2 = 0 Then '---1 For j = 0 To 9 If j = 5 Or j = 7 Then '----2 For k = 0 To 9 If k Mod 2 = 1 Then '----3 v = "_" & i & j & k 'tinh toan Range("A" & m) = v ' m = m + 1 ' End If '----3 count = count + 1 Next k End If '----2 Next j End If '----1 Next i MsgBox count '-----so buoc xu ly End Sub

thì chỉ chạy 100 bước là ra kết quả rùi , tức là vét có chọn lọc ^^!

Mình nghĩ "vét có chọn lọc" thì chay 50 bước thôi chứ nhỉ. Híc
Thân

Kiều Mạnh · 4/3/19

concogia đã viết:
Mình nghĩ "vét có chọn lọc" thì chay 50 bước thôi chứ nhỉ. Híc
Thân

Chắc Anh cò lại có cách Vét xúc tích, ngắn gọn hơn hỷ ??!!

concogia · 4/3/19

kieu manh đã viết:
Chắc Anh cò lại có cách Vét xúc tích, ngắn gọn hơn hỷ ??!!

Có gì mà "súc" với "tích" chú Mạnh ơi
Số đầu tiên là số chẵn thì chạy từ 0 đến 8 step 2 (5 em)
Số thứ hai la 5 hoặc 7 thì chạy từ 5 đến 7 step 2 (2 em)
Số cuối là số lẻ thì chạy từ 1 đến 9 step 2 (5 em)
5 em, 2 em rồi lại 5 em thì ....50 chục bước thôi. Híc
Thân

anhtuanle123 · 4/3/19

hùi trước mình cũng nhìn nhận vấn đề như bác đó !
nhưng bác thử hình dung thế này , 50 đó chỉ là kết quả của thôi , còn 100 là số bước đi để tìm ra kết quả đó (100 này cũng là đại khái ) , cũng giống như 1 cái cây ,
có thân cây , cành , lá và quả !
giờ muốn tìm số quả trên cây , giả xử cái cây rất to , cách làm chắc ăn nhất là mình phải tìm từng cành 1 , 1 số cành sẽ không có quả , nhưng giả xử có tín hiệu nào đó để biết được cành muốn kiểm tra không có quả để khỏi tìm tốn công , thì ta giảm được thời gian kiểm tra và tìm kiếm !

như trong bài thì bước 1 , ta phải chạy 10 bước , có 5 bước thỏa để đi tiếp và 5 bước không thỏa !
5 bước không thỏa này thì cũng phải tính toán thì nó mới biết là không thỏa chứ nhỉ nên coi như là thêm 5 bước !

5 bước thỏa sẽ đi đến cấp sâu hơn , gồm 10 bước , có 2 bước thỏa để đi tiếp và 8 bước không thỏa !

2 bước thỏa sẽ đi đến cấp sâu hơn , gồm 10 bước (chắc chắn 1 rùi ) , vì trong cấp thứ 3 này làm gì kệ nó , miễn chạy đủ 10 bước là được !

vậy nếu tính các con đường đi đến cấp cuối cùng thì có 5 * 2 * 10 = 100 bước !
5 bước không thỏa đầu tiên !
5 bước thỏa đầu tiên * 8 bước đi mà không đến đích mức thứ 2 = 40 bước không thỏa thứ 2 !

tổng cộng có 100 + 5 + 40 =145 bước phải đi !
là bước phải đi , ko phải là bước đến đích !

vanmanhvcu · 4/3/19

CHAOQUAY đã viết:
Có lẽ nếu tiện, bạn đính kèm 1 file có mô hình lớn nhất lên thử xem sao.

Mô hình tổng quát đây bạn nhé !
@_@
có lẽ chỉ có cao thủ của cao thủ mới có thể làm nổi.

befaint · 4/3/19

Cuộn trải ra thì thành tấm, nếu không cần chia chiều rộng mà chỉ chia chiều dài thì coi như thanh.
GPE có bài toán tối ưu hóa cắt tấm, cắt thanh tám mười đời rồi.

vanmanhvcu · 4/3/19

befaint đã viết:
Cuộn trải ra thì thành tấm, nếu không cần chia chiều rộng mà chỉ chia chiều dài thì coi như thanh.
GPE có bài toán tối ưu hóa cắt tấm, cắt thanh tám mười đời rồi.

Sorry bác, bài này chỉ chia chiều rộng thôi !

Bài đã được tự động gộp: 4/3/19

HieuCD đã viết:

Nhìn mục lục rất mê, tiếc rằng không đủ sức tiêu hóa nội dung

Thay sub KetQua bằng sub TestRow_Ketqua để chạy số dòng số cột thay đổi, chỉ nhập lại địa chỉ dữ liệu chuẩn
Số dòng tăng sẽ làm code chậm rất nhiều, có thể thiếu bộ nhớ

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 GPE2()
  Tg = Timer
  dkR1 = Range("F5:F11").Value:  dkR2 = Range("J5:J11").Value 'Dieu kien Dong
  tRow = Range("B2:E4").Value 'Tham so dong
  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 'Tham so cot
  dkC1 = 4:  dkC2 = 7 ' Dieu kien Cot
  N = 4 'So gia tri lua chon
  Call ChinhHop
  Call AddCol
  Range("M5", Range("P1000000").End(xlUp)).ClearContents
  Call TestRow_KetQua
  [l2] = Timer - Tg
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
        End If
      Next i
      If Tong <= dkC2 Then
        For i = 1 To sRow
          Arr(i) = cArr(i, c)
        Next i
        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 TestRow_KetQua()
  Dim tArr() As Long, ChayNhanhLen As String
  ReDim Arr(1 To sRow, 1 To sCol)
  ReDim tArr(1 To 2, 1 To sCol)
  For j = 1 To sCol
    tArr(1, j) = 1: tArr(2, j) = UBound(colArr(j))
  Next j
  k = 0
  Do While ChayNhanhLen = Empty
    For i = 1 To sRow
      Tong = 0
      For j = 1 To sCol
        Tong = Tong + tRow(1, j) * colArr(j)(tArr(1, j))(i)
      Next j
      Tong = Tong * tCol(i, 1)
      If Tong < dkR1(i, 1) Or Tong > dkR2(i, 1) Then GoTo Thoat
    Next i
    For i = 1 To sRow
      For j = 1 To sCol
        Arr(i, j) = colArr(j)(tArr(1, j))(i)
      Next j
    Next i
    k = k + 1
    Range("M" & (sRow + 1) * (k - 1) + 5).Resize(sRow, sCol) = Arr
Thoat:
    For j = sCol To 1 Step -1
      If tArr(1, j) < tArr(2, j) Then
        tArr(1, j) = tArr(1, j) + 1
        For i = j + 1 To sCol
          tArr(1, i) = 1
        Next i
        Exit For
      Else
        If j = 1 Then Exit Sub
      End If
    Next j
  Loop
End Sub

các bác @HieuCD @anhtuanle123 @CHAOQUAY có thể giải thích cụ thể từng bước giải thuật để cho mọi người cùng hiểu được không?
tôi và có thể có cả người khác cũng đang chập chững VBA, xem code các bác thì tiêu hóa chưa được tốt lắm, mong thông cảm.

befaint · 4/3/19

vanmanhvcu đã viết:
bài này chỉ chia chiều rộng thôi !

Chiều rộng hay chiều dài chỉ là tương đối khi gốc tham chiếu thay đổi thì nó lộn ngược cho nhau.
Chỉ xử lý một chiều thì ứng với đường thẳng, là thanh, là dây đó.

HieuCD · 4/3/19

vanmanhvcu đã viết:
Sorry bác, bài này chỉ chia chiều rộng thôi !

Bài đã được tự động gộp: 4/3/19

các bác @HieuCD @anhtuanle123 @CHAOQUAY có thể giải thích cụ thể từng bước giải thuật để cho mọi người cùng hiểu được không?
tôi và có thể có cả người khác cũng đang chập chững VBA, xem code các bác thì tiêu hóa chưa được tốt lắm, mong thông cảm.

Code phức tạp khó giải thích
Bạn dùng file của mình để dể thêm cột và dòng, vùng màu xanh là dữ liệu nhập vào theo đúng cấu trúc cột dòng, có thể thêm bớt dòng cột, các ô khác xóa cũng được. Địa chỉ vùng màu xanh bạn khai báo lại trong code ở biến DiaChi, kết quả trả về ở sheet KetQua
Chạy không được thì gởi lại file với dữ liệu mới

CHAOQUAY · 4/3/19

vanmanhvcu đã viết:
Sorry bác, bài này chỉ chia chiều rộng thôi !

Bài đã được tự động gộp: 4/3/19

các bác @HieuCD @anhtuanle123 @CHAOQUAY có thể giải thích cụ thể từng bước giải thuật để cho mọi người cùng hiểu được không?
tôi và có thể có cả người khác cũng đang chập chững VBA, xem code các bác thì tiêu hóa chưa được tốt lắm, mong thông cảm.

Dưới đây là viết giải thuật theo file bài 1, việc khai báo các vùng dữ liệu đơn giản nên ko nêu ra ở đây
Lập luận : Tại mỗi dòng có 4 cột. Mỗi cột có 4 khả năng là 0 - 3 => sẽ có 4^4 = 256 chỉnh hợp cho mỗi dòng, 256 mẫu chỉnh hợp này là không đổi, tuy nhiên mỗi dòng sẽ chỉ khớp với 1 số chỉnh hợp nào đó để đảm bảo kết quả tính tại H5:H11 phù hợp với cận trên & dưới của yêu cầu ( F5:F11 & J5:J11 )
Vì vậy, việc đầu tiên là tìm xem trên mỗi dòng, có các chỉnh hợp nào ăn khớp. Sau khi tìm được, các chỉnh hợp khớp này đã đảm bảo yêu cầu theo dòng!!!
Tiếp theo, nếu đã xác định dược số chỉnh hợp khớp cho mỗi dòng thì từ đó có thể lập tổ hợp chập 7 của các chỉnh hợp của mỗi dòng với nhau. Lúc này sẽ xét điều kiện thứ 2 : Cộng dồn các số cùng cột của chỉnh hợp của mỗi dòng, nếu đạt yêu cầu về số lượng ( >=4 & <=7 ) sẽ được nhặt ra làm kết quả.
Vậy bài này gồm 3 bước chính :
Bước 1 : Lập các mẫu chỉnh hợp chung ( 256 mẫu )
Bước 2 : Trên mỗi dòng, lọc trong 256 ra các mẫu phù hợp đảm bảo kết quả phép tính trên mỗi dòng >= yêu cầu 0.85 & <= yêu cầu 1.2
Bước 3 : Lập tổ hợp chập 7, ghép các mẫu của 7 dòng với nhau, cộng dồn theo cột nếu tất cả các cột đều >=4 & <=7 sẽ lấy làm kết quả
Trong sub BaiToan, các bước thực hiện như sau

Mã:

'Bước 1 : Lập 256 mẫu chỉnh hợp chung, điền vào mảng Tam
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
'Xong Bước 1 : Lập 256 mẫu chỉnh hợp chung, điền vào mảng Tam
'Lập mảng tích, là phép tính Dòng 2 * Dòng 4 / Dòng 3. Tích này dùng chung để tính tổng theo dòng ( Đây chỉ là bước phụ )
ReDim Tich(1 To 4)
For j = 1 To 4
    Tich(j) = BE2(1, j) * BE4(1, j) / BE3(1, j)
Next j
'Xong Lập mảng tích, là phép tính Dòng 2 * Dòng 4 / Dòng 3. Tích này dùng chung để tính tổng theo dòng ( Đây chỉ là bước phụ )
'Bước 2 : Tìm các chỉnh hợp đạt yêu cầu cho mỗi dòng, điền vào mảng ToHop
ReDim ToHop(1 To 7, 1 To 1)
For i = 1 To 7
    DicTT.RemoveAll
    z = 0
    For Each Th In Tam ' Tại dòng thứ I, quét toàn bộ mẫu chỉnh hợp của mảng Tam
        Cong = 0
        For j = 0 To 3 ' Quét các phần tử của chỉnh hợp Th
            Cong = Cong + Tich(j + 1) * Th(j) ' Lấy giá trị của phần tử của chỉnh hợp * với giá trị tương ứng của mảng Tich, rồi cộng dồn lại
        Next j
        Cong = Cong * CotA(i, 1) ' Kết quả cộng dồn * vối cột A = giá trị tại cột H
        If Cong >= YCau085(i, 1) And Cong <= YCau12(i, 1) Then ' Nếu cộng dồn theo dòng đạt yêu cầu, điền vào dictt
            z = z + 1
            DicTT.Add z, Th
        End If
    Next Th
    ToHop(i, 1) = DicTT.Items ' Tất cả các chỉnh hợp đạt yêu cầu của mỗi dòng được nạp vào mảng ToHop tại dòng tương ứng
Next i
'Xong Bước 2 : Tìm các chỉnh hợp đạt yêu cầu cho mỗi dòng, điền vào mảng ToHop
'Bước 3 : Lập tổ hợp chập 7 các mẫu phù hợp của mỗi dòng, cộng dồn & kiểm tra số lượng theo từng cột. 
'Nếu tất cả các cột đều đảm bảo >=4 & <=7 thỉ lưu làm kết quả
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
'Xong Bước 3 : Lập tổ hợp chập 7 các mẫu phù hợp của mỗi dòng, cộng dồn & kiểm tra số lượng theo từng cột. 
'Xuất kết quả vào Kq
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
'Xong Xuất kết quả vào Kq
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

Code trên đây là làm theo trình tự Dòng _ Cột. Làm theo Cột _ Dòng cũng sẽ thu được kết quả tương tự

vanmanhvcu · 5/3/19

giải thích rõ ràng, dễ hiểu.
cám ơn bác @HieuCD , @CHAOQUAY.

[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 (1 người xem)

Người dùng đang xem chủ đề này

Thành viên chính thức

File đính kèm

Thành viên tiêu biểu

Thành viên gắn bó

Thành viên chính thức

File đính kèm

Thành viên gắn bó

Thành viên chính thức

Thành viên gắn bó

Thành viên chính thức

Thành viên gắn bó

Thành viên tiêu biểu

Chuyên gia GPE

Thành viên gắn bó

Thành viên chính thức

Thành viên chính thức

File đính kèm

Chuyên gia GPE

Thành viên chính thức

Thành viên gắn bó

Thành viên tiêu biểu

File đính kèm

Chuyên gia GPE

File đính kèm

Thành viên tích cực

Thành viên chính thức

Thành viên tích cực

File đính kèm

Thành viên tiêu biểu

Thành viên tích cực

Thành viên tiêu biểu

Thành viên gắn bó

Thành viên chính thức

Thành viên gắn bó

I don't program, I beat code into submission!!!

Thành viên chính thức

Thành viên tiêu biểu

Thành viên gắn bó

Chuyên gia GPE

Gội rồi mới Cạo

I don't program, I beat code into submission!!!

Gội rồi mới Cạo

Thành viên tiêu biểu

Thành viên chính thức

File đính kèm

|||||||||||||

Thành viên chính thức

|||||||||||||

Chuyên gia GPE

File đính kèm

Thành viên gắn bó

Thành viên chính thức

Thời gian đếm ngược.