Nhờ anh/chị giúp code VBA tìm kiếm
Em đang có 1 bài toán cần tìm kiếm nhiều giá trị và trả về theo điều kiện cụ thể như sau:
Có 2 trường hợp tìm kiếm
Trường hợp 1,
Tìm nhiều giá trị 1 lúc và có đủ 3 thông tin như 3 cột B,C,D
Kết quả trả về sheets Result (lấy thông tin từ cột Import) với yêu cầu như sau
– Trả về các dòng hàng tương ứng thỏa mãn điều kiện là cùng Item và số lượng lớn hơn vừa đủ
– Nếu 1 dòng không đủ số lượng thì trả về nhiều dòng để đủ tổng số lượng yêu cầu
– Nếu số lượng tồn không đủ số lượng xuất thì sẽ cảnh báo bằng màu sắc
Trường hợp 2.
Tìm kiếm nhiều giá trị 1 lúc và chỉ có thông tin cột B, C
Kết quả trả về tương tự, chỉ là ít hơn 1 điều kiện tìm kiếmChi tiết thông tin như tệp đính kèm, nhờ anh/chị giúp đỡ ạ
Em cảm ơn ạ
Làm theo ý hiểu.
Bạn thử code sau hãy nhấn vào mặt cười ở Sheet Result để xem và kiểm tra kết quả(chỉ cho trường hợp 1), trường hợp 2 và tô màu, kẻ khung định dạng bạn tự làm lấy.
Mình đã sửa lại file của bạn theo nhận định chủ quan của mình, bạn tham khảo
Lần sau nhớ tạo file giả (lập) chứ không cần file số liệu thực như của bạn đâu nha.
www.giaiphapexcel.com/diendan/threads/nh%E1%BB%9D-anh-ch%E1%BB%8B-gi%C3%BAp-code-vba-t%C3%ACm-ki%E1%BA%BFm.161165/post-1076595
Theo mình hiểu thì bài này không đơn giản, như 2 bài giải phía trên đã làm.
Dạng như Solver, nếu mã ABC nào đó có 5 giá trị, phải tìm ra các trường hợp để tổng thỏa 2 điều kiện:
* Lớn hơn hoặc bằng giá trị cho trước
* Chênh lệch > giá trị cho trước là nhỏ nhất
Nếu chỉ có trường hợp tối đa 5 giá trị (như trong ví dụ), có thể dùng 5 cái for…next để giải quyết
Vấn đề là trong thực tế, mã ABC, hay XYZ nào đó có thể >5 giá trị, nên số lượng loop là không xác định được.
Có thể dùng VBA Solver, nhưng rất phức tạp, mình vẫn chưa nghĩ ra giải pháp nào khả thiVâng, đúng như bác phân tích ạ, thực tế số lượng giá trị là không có giới hạn cụ thể nên bài toán này thật sự khó ạ
về phần chênh lệch > giá trị cho trước là nhỏ nhất cái này có thể bỏ bớt cũng được ạ, chỉ tổng các giá trị cần lớn hơn hoặc bằng giá trị cho trước, nếu không thì báo không còn đủ ạ
ngoài ra trường hợp tìm kiếm thứ 2 là bỏ qua thông tin "import CD" có thể tách thành 1 bảng kết quả khác với câu lệnh tìm kiếm khác cũng được , để giảm bớt phần nào những sự phức tạp ạ
Thêm sheet Result2, chạy sub main
Option Explicit
Sub Main()
Dim arr(), aDL(), S, res(), res2()
Dim sRow&, k&, i&, j&, iTem$, QTy#, iCD$
For i = 5 To 7
Range("J" & i).Font.Color = -16776961
Next i
With Sheets("Import")
aDL = .Range("A3:I" & .Range("A1048000").End(xlUp).Row).Value
End With
sRow = UBound(aDL)
ReDim res(1 To sRow, 1 To 8)
ReDim res2(1 To sRow, 1 To 8)
With Sheets("Check")
arr = .Range("B2:D" & .Range("B1048000").End(xlUp).Row).Value
End With
For i = 1 To UBound(arr)
iTem = arr(i, 1): QTy = arr(i, 2): iCD = CStr(arr(i, 3))
If iTem <> Empty And QTy > 0 Then
If iCD <> Empty Then
Call SumFind(aDL, res, k, sRow, iTem, QTy, iCD)
End If
End If
Next i
With Sheets("Result")
i = .Range("A1048000").End(xlUp).Row
If i > 2 Then .Range("A3:H" & i).Clear
If k Then
.Range("A3").Resize(k, 8) = res
.Range("A3").Resize(k, 8).Borders.LineStyle = 1
For i = 3 To k + 2
If .Range("B" & i).Value = Empty Then .Range("A" & i).Font.Color = -16776961
Next i
End If
End With
k = 0
ReDim res(1 To sRow, 1 To 8)
For i = 1 To UBound(arr)
iTem = arr(i, 1): QTy = arr(i, 2): iCD = CStr(arr(i, 3))
If iCD = Empty Then
If iTem <> Empty And QTy > 0 Then
Call SumFind(aDL, res, k, sRow, iTem, QTy, iCD)
End If
End If
Next i
With Sheets("Result2")
i = .Range("A1048000").End(xlUp).Row
If i > 2 Then .Range("A3:H" & i).Clear
If k Then
.Range("A3").Resize(k, 8) = res
.Range("A3").Resize(k, 8).Borders.LineStyle = 1
For i = 3 To k + 2
If .Range("B" & i).Value = Empty Then .Range("A" & i).Font.Color = -16776961
Next i
End If
End With
End Sub
Private Sub SumFind(aDL, aRes, k, sRow, iTem, QTy, iCD)
Dim Data(), arr(), S, tmp#, tSum#, dMin#, i&, N&, q&, j&, r&, t$
dMin = 1000000000
For i = 1 To sRow
tmp = aDL(i, 9)
If aDL(i, 1) = iTem And tmp > 0 Then
If CStr(aDL(i, 2)) = iCD Or iCD = Empty Then
If tmp = QTy Then
k = k + 1
For j = 1 To 6
aRes(k, j) = aDL(i, j)
Next j
aRes(k, 7) = aDL(i, 8): aRes(k, 8) = aDL(i, 9)
aDL(i, 1) = Empty
Exit Sub
ElseIf tmp > QTy Then
If dMin > tmp Then dMin = tmp: t = "," & i
ElseIf tmp > 0 Then
N = N + 1
ReDim Preserve Data(1 To 2, 1 To N)
Data(1, N) = tmp: Data(2, N) = i
End If
End If
End If
Next i
If N > 0 Then
Call QuickSort(Data)
ReDim arr(1 To N)
arr(1) = 1: tSum = Data(1, 1)
N = 1: q = 1
Do While QTy <> -1 'tSum
If arr(1) = UBound(Data, 2) Then Exit Do
If tSum > QTy Then
If dMin > tSum Then
dMin = tSum
t = Empty
For i = 1 To N
t = t & "," & Data(2, arr(i))
Next i
End If
q = arr(N - 1) + 1
tSum = tSum - Data(1, arr(N)) - Data(1, arr(N - 1)) + Data(1, q)
N = N - 1
arr(N) = q
Else
If q = UBound(Data, 2) Then
q = arr(N - 1) + 1
tSum = tSum - Data(1, arr(N)) - Data(1, arr(N - 1)) + Data(1, q)
N = N - 1
arr(N) = q
Else
q = q + 1
tSum = tSum + Data(1, q)
N = N + 1
arr(N) = q
End If
End If
If QTy = tSum Then
t = Empty
For i = 1 To N
t = t & "," & Data(2, arr(i))
Next i
Exit Do
End If
Loop
End If
If t <> Empty Then
S = Split(t, ",")
For i = 1 To UBound(S)
r = CLng(S(i))
k = k + 1
For j = 1 To 6
aRes(k, j) = aDL(r, j)
Next j
aRes(k, 7) = aDL(r, 8): aRes(k, 8) = aDL(r, 9)
aDL(r, 1) = Empty
Next i
Else
k = k + 1
aRes(k, 1) = iTem
End If
End Sub
Private Sub QuickSort(Data)
Dim oSList As Object, sArr, S, j&, k&, jk&, m&
Set oSList = CreateObject("System.Collections.SortedList")
For j = LBound(Data, 2) To UBound(Data, 2)
oSList.iTem(Data(1, j)) = oSList.iTem(Data(1, j)) & "," & j
Next j
sArr = Data
For j = 0 To oSList.Count - 1
S = Split(oSList.GetByIndex(j), ",")
For m = 1 To UBound(S)
jk = CLng(S(m))
k = k + 1
Data(1, k) = sArr(1, jk): Data(2, k) = sArr(2, jk)
Next m
Next j
Set oSList = Nothing
End Subwww.giaiphapexcel.com/diendan/threads/nh%E1%BB%9D-anh-ch%E1%BB%8B-gi%C3%BAp-code-vba-t%C3%ACm-ki%E1%BA%BFm.161165/post-1076776
Khóa học Power PI – Ứng dung trong Nhân sự
TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...
Xem khóa học
Bình luận