' Bật tham chiếu đến "Microsoft Scripting Runtime"
' Bằng cách vào Tools -> References -> Tích vào "Microsoft Scripting Runtime" trong cửa sổ VBA Editor.
Option Explicit
Sub TimKiemToHopSanPham()
' --- THIẾT LẬP CÁC THAM SỐ ---
Dim wsData As Worksheet
Set wsData = ThisWorkbook.Sheets("Sheet1") ' << Thay "Sheet1" bằng tên sheet chứa dữ liệu của bạn
Dim targetValue As Double
Dim numProductsToBuy As Integer
Dim numIterations As Long
On Error Resume Next
targetValue = CDbl(wsData.Range("F1").Value)
numProductsToBuy = CInt(wsData.Range("F2").Value)
If Err.Number <> 0 Then
MsgBox "Vui lòng kiểm tra lại giá trị tại ô F1 và F2. F1 phải là số tiền, F2 phải là số lượng mã hàng.", vbCritical, "Lỗi Dữ Liệu Đầu Vào"
Exit Sub
End If
On Error GoTo 0
numIterations = 100000 ' Số lần thử, có thể tăng lên để kết quả tốt hơn nhưng sẽ lâu hơn
' --- KIỂM TRA ĐẦU VÀO ---
If targetValue <= 0 Or numProductsToBuy <= 0 Then
MsgBox "Số tiền và số mã hàng phải lớn hơn 0.", vbExclamation, "Dữ Liệu Không Hợp Lệ"
Exit Sub
End If
Application.ScreenUpdating = False
' --- ĐỌC DỮ LIỆU SẢN PHẨM ---
Dim lastRow As Long
lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
If lastRow < 3 Then
MsgBox "Không tìm thấy dữ liệu sản phẩm.", vbExclamation, "Lỗi Dữ Liệu"
Exit Sub
End If
Dim allProducts As Variant
allProducts = wsData.Range("A3:C" & lastRow).Value
Dim totalProductCount As Long
totalProductCount = UBound(allProducts, 1)
If numProductsToBuy > totalProductCount Then
MsgBox "Số mã hàng cần mua (" & numProductsToBuy & ") lớn hơn tổng số mã hàng có trong danh sách (" & totalProductCount & ").", vbExclamation, "Lỗi"
Exit Sub
End If
' --- KHỞI TẠO BIẾN LƯU KẾT QUẢ TỐT NHẤT ---
Dim bestCost As Double
Dim bestCombination As Object 'Sử dụng Dictionary
Set bestCombination = Nothing
bestCost = 0
Randomize ' Khởi tạo bộ sinh số ngẫu nhiên
' --- BẮT ĐẦU VÒNG LẶP TÌM KIẾM ---
Dim i As Long
For i = 1 To numIterations
' Lấy ngẫu nhiên N sản phẩm
Dim currentProducts As Variant
currentProducts = GetRandomProducts(allProducts, numProductsToBuy)
' Tính toán khối lượng và chi phí cho các sản phẩm đã chọn
Dim currentSolution As Object
Set currentSolution = CalculateQuantitiesAndCost(currentProducts, targetValue)
If Not currentSolution Is Nothing Then
Dim currentCost As Double
currentCost = currentSolution("TotalCost")
' Nếu kết quả hiện tại tốt hơn kết quả tốt nhất đã lưu -> Cập nhật
If currentCost > bestCost Then
bestCost = currentCost
Set bestCombination = currentSolution
End If
End If
Next i
' --- HIỂN THỊ KẾT QUẢ ---
DisplayResults bestCombination, targetValue
Application.ScreenUpdating = True
MsgBox "Hoàn tất! Kiểm tra sheet 'KetQua' để xem kết quả.", vbInformation, "Thông Báo"
End Sub
Private Function GetRandomProducts(ByVal allProducts As Variant, ByVal count As Integer) As Variant
' Hàm này lấy ra 'count' sản phẩm ngẫu nhiên không trùng lặp từ danh sách
Dim productCount As Long
productCount = UBound(allProducts, 1)
Dim indices As Object
Set indices = CreateObject("System.Collections.ArrayList")
Dim i As Long
For i = 1 To productCount
indices.Add i
Next i
' --- SỬA LỖI ---
Dim selectedProducts() As Variant ' 1. Khai báo mảng động
ReDim selectedProducts(1 To count, 1 To 3) ' 2. Cấp phát lại kích thước khi đã biết 'count'
' --- KẾT THÚC SỬA LỖI ---
Dim r As Long
Dim selectedIndex As Long
For i = 1 To count
r = Int(indices.Count * Rnd())
selectedIndex = indices(r)
selectedProducts(i, 1) = allProducts(selectedIndex, 1) ' Tên
selectedProducts(i, 2) = allProducts(selectedIndex, 2) ' Đơn vị
selectedProducts(i, 3) = allProducts(selectedIndex, 3) ' Đơn giá
indices.RemoveAt r
Next i
GetRandomProducts = selectedProducts
End Function
Private Function CalculateQuantitiesAndCost(ByVal selectedProducts As Variant, ByVal target As Double) As Object
' Hàm này tính toán khối lượng để tối ưu hóa chi phí
Dim num As Integer
num = UBound(selectedProducts, 1)
Dim prices() As Double
ReDim prices(1 To num)
Dim weights() As Double
ReDim weights(1 To num)
Dim totalWeightedPrice As Double
totalWeightedPrice = 0
Dim j As Integer
For j = 1 To num
' Tạo các trọng số ngẫu nhiên không quá chênh lệch (ví dụ: trong khoảng 0.85 đến 1.15)
weights(j) = 0.85 + Rnd() * 0.3
prices(j) = CDbl(selectedProducts(j, 3))
totalWeightedPrice = totalWeightedPrice + prices(j) * weights(j)
Next j
If totalWeightedPrice = 0 Then Exit Function
' Tính toán hệ số để tổng tiền tiệm cận với ngân sách
Dim scaleFactor As Double
scaleFactor = target / totalWeightedPrice
Dim totalCost As Double
totalCost = 0
Dim resultsDict As Object
Set resultsDict = CreateObject("Scripting.Dictionary")
Dim itemsCollection As Collection
Set itemsCollection = New Collection
For j = 1 To num
' Làm tròn xuống để đảm bảo tổng tiền không vượt ngân sách
Dim qty As Double
qty = Application.WorksheetFunction.RoundDown(scaleFactor * weights(j), 2)
Dim cost As Double
cost = qty * prices(j)
Dim itemDict As Object
Set itemDict = CreateObject("Scripting.Dictionary")
itemDict.Add "Name", selectedProducts(j, 1)
itemDict.Add "Quantity", qty
itemDict.Add "Price", prices(j)
itemDict.Add "SubTotal", cost
itemsCollection.Add itemDict
totalCost = totalCost + cost
Next j
resultsDict.Add "Items", itemsCollection
resultsDict.Add "TotalCost", totalCost
Set CalculateQuantitiesAndCost = resultsDict
End Function
Private Sub DisplayResults(ByVal result As Object, ByVal target As Double)
' Hàm này hiển thị kết quả ra một sheet mới
If result Is Nothing Then
MsgBox "Không tìm thấy tổ hợp nào phù hợp.", vbExclamation, "Không Có Kết Quả"
Exit Sub
End If
Dim wsResult As Worksheet
On Error Resume Next
ThisWorkbook.Worksheets("KetQua").Delete
On Error GoTo 0
Set wsResult = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsResult.Name = "KetQua"
With wsResult
.Range("A1").Value = "KẾT QUẢ TỐI ƯU HÓA ĐƠN HÀNG"
.Range("A1:D1").Merge
.Range("A1").Font.Bold = True
.Range("A1").Font.Size = 14
.Range("A1").HorizontalAlignment = xlCenter
.Range("A3").Value = "Tên hàng"
.Range("B3").Value = "Khối lượng (Kg)"
.Range("C3").Value = "Đơn giá"
.Range("D3").Value = "Thành tiền"
.Range("A3:D3").Font.Bold = True
Dim items As Collection
Set items = result("Items")
Dim i As Integer
For i = 1 To items.Count
.Cells(i + 3, 1).Value = items(i)("Name")
.Cells(i + 3, 2).Value = items(i)("Quantity")
.Cells(i + 3, 3).Value = items(i)("Price")
.Cells(i + 3, 4).Value = items(i)("SubTotal")
Next i
Dim lastDataRow As Long
lastDataRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(lastDataRow + 1, 3).Value = "Tổng cộng"
.Cells(lastDataRow + 1, 3).Font.Bold = True
.Cells(lastDataRow + 1, 4).Formula = "=SUM(D4:D" & lastDataRow & ")"
.Cells(lastDataRow + 1, 4).Font.Bold = True
.Cells(lastDataRow + 3, 3).Value = "Ngân sách"
.Cells(lastDataRow + 3, 4).Value = target
.Cells(lastDataRow + 4, 3).Value = "Chênh lệch"
.Cells(lastDataRow + 4, 4).Formula = "=" & .Cells(lastDataRow + 3, 4).Address(False, False) & "-" & .Cells(lastDataRow + 1, 4).Address(False, False)
' Định dạng số
.Range("B4:D" & lastDataRow + 4).NumberFormat = "#,##0.00"
.Columns("A:D").AutoFit
End With
End Sub
