Option Explicit: Option Base 1
Function GomKeo(LookUpRange As Range, QuiCach As String, SoLuong As Long) As Variant
Dim Clls As Range
Dim Dem As Byte, Rws As Long, Ton As Long
Rws = LookUpRange.Rows.Count: ReDim MDL(Rws, 2)
For Each Clls In LookUpRange.Cells(1, 1).Resize(Rws)
If InStr(Clls.Value, QuiCach) > 0 Then
Dem = Dem + 1
MDL(Dem, 1) = Clls.Value
Ton = Clls.Offset(, 2).Value
If Ton <= SoLuong Then
MDL(Dem, 2) = Ton
SoLuong = SoLuong - Ton
Else
MDL(Dem, 2) = SoLuong: SoLuong = 0
Exit For
End If
End If
Next Clls
If SoLuong > 0 Then
Dem = Dem + 1
MDL(Dem, 1) = QuiCach: MDL(Dem, 2) = -SoLuong
End If
For Ton = Dem + 1 To Rws
MDL(Ton, 1) = "": MDL(Ton, 2) = ""
Next Ton
GomKeo = MDL
End FunctionNhờ anh giải thích thêm :
Thuật tóan em tính làm như sau, Anh xem có OK?
Không yêu cầu nhưng dùng công thức để tham khảo nhé.
(1) Thêm cột chẳng qua giữ lại số liệu của bạn để đối chiếu mà thôi.
------
----
Em làm thử như sau, có dùng sh Tmp cho nhanh, lâu quá không viết code nên hơi dài và luộm thuộm. Em sẽ trau chuốt lại sau.
Dim i As Long, endR As Long
Dim myRng As Range
Dim Quycach As String, SlCan As Long, SLChia As Long, SlCon As Long
Sub LayData()
With Sheets("Tmp")
.Range("A2:J1000").ClearContents
End With
With Sheets("Data")
Quycach = .Range("E2")
endR = .Cells(65000, 1).End(xlUp).Row
Sheets("Tmp").Range("D2:D" & endR).Value = .Range("A2:A" & endR).Value
Sheets("Tmp").Range("C2:C" & endR).Value = .Range("C2:C" & endR).Value
End With
With Sheets("Tmp")
With .Range("A2:A" & endR)
.FormulaR1C1 = "=tachquycach(RC4)"
.Value = .Value
End With
With .Range("B2:B" & endR)
.FormulaR1C1 = "=tachk(RC4)"
.Value = .Value
End With
With .Range("F2")
.Value = Quycach
End With
Set myRng = .Range("A1:C" & endR)
End With
myRng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Tmp").Range( _
"F1:F2"), CopyToRange:=Sheets("Tmp").Range("H1:J1"), Unique:=False
ActiveWorkbook.Names("Criteria").Delete
ActiveWorkbook.Names("Extract").Delete
Set myRng = Nothing
chia
End Sub
Sub chia()
endR = Sheets("Tmp").Cells(65000, 8).End(xlUp).Row
Set myRng = Sheets("Tmp").Range("H2:J" & endR)
myRng.Sort Key1:=Sheets("Tmp").Range("I2"), Order1:=xlAscending, Header:=xlGuess
j = 2
SlCon = 0
Sheets("data").Select
SlCan = Range("F2")
Range("H2:I100").ClearContents
For i = 1 To endR - 1
SLChia = myRng(i, 3)
If SLChia < SlCan Then
Range("H" & j).Value = myRng(i, 1) & "-" & myRng(i, 2)
Range("I" & j).Value = SLChia
Else
Range("H" & j).Value = myRng(i, 1) & "-" & myRng(i, 2)
Range("I" & j).Value = SlCan
GoTo bien
End If
SlCan = SlCan - SLChia
j = j + 1
Next
If SlCan > 0 Then
Range("H" & j).Value = Quycach
Range("I" & j).Value = -SlCan
End If
bien:
End SubOption Explicit
Option Base 1
Function TachChu(MyStr As String, n As Long) As String
Dim aSplit() As String
Dim SearchChar As String
Dim i As Long, j As Long
SearchChar = "-"
MyStr = Trim(MyStr)
If Len(MyStr) = 0 Or n > 3 Then Exit Function
aSplit = Split(MyStr, SearchChar, 3)
TachChu = Trim(aSplit(n - 1))
End Function
Function TachQuyCach(MyStr As String) As String
TachQuyCach = Trim(TachChu(MyStr, 1))
End Function
Function TachK(MyStr As String) As String
TachK = Trim(TachChu(MyStr, 2))
End Function
Em cũng tính làm theo Find Methode nhưng mà lâu nàgy không dùng nên làm AdFi, phần trích lọc sẽ sửa lại.Nếu là macro thì mình sẽ làm như vầy:
(*) Lấy 1 trang tính làm FORM, Xóa dữ liệu trên nó;
(*) Dùng phương thức tìm với thông số XlPart để chép toàn bô các records thỏa điều kiện (= với quy cách) từ trang tính gốc sang đó;
(*) Xếp theo chiều ưng í
(*) Thực hiên tiếp như hàm trên đã viết thôi, OK không vậy?
Chúc vui!
Cuối cùng cũng xong. Khá vất vả. Bạn dùng thử xem sao nhé:
Function ChiaKeo(QuyCachCan As String, SoLuongCan As Integer, BangQuyCach As Range, CotSoLuong As Integer, TT As Integer, Optional SL As Boolean = False) As String
Dim K As Integer, STT As Integer, Rng As Range, Tong
Dim QuyCach()
STT = 0
K = Application.WorksheetFunction.CountIf(BangQuyCach.Resize(, 1), QuyCachCan & "*")
ReDim Preserve QuyCach(K - 1)
For Each cll In BangQuyCach.Resize(, 1)
If InStr(cll.Value, QuyCachCan) > 0 Then
QuyCach(STT) = CInt(Right(cll.Value, Len(cll.Value) - InStr(cll.Value, "-")))
STT = STT + 1
End If
Next
For i = 1 To K
Set Rng = BangQuyCach.Resize(, 1).Find(what:=QuyCachCan & "-" & Application.WorksheetFunction.Small(QuyCach(), i), After:=BangQuyCach.Cells(BangQuyCach.Rows.Count, 1), LookAt:=xlWhole)
Tong = Tong + Rng.Offset(, CotSoLuong - 1).Value
If Tong >= SoLuongCan Then
K = i
Exit For
End If
Next
If TT <= K Then Set Rng = BangQuyCach.Resize(, 1).Find(what:=QuyCachCan & "-" & Application.WorksheetFunction.Small(QuyCach(), TT), LookAt:=xlWhole)
If TT < K Or (TT = K And Tong <= SoLuongCan) Then
ChiaKeo = IIf(SL = True, Rng.Offset(, CotSoLuong - 1).Value, Rng.Value)
ElseIf TT = K And Tong > SoLuongCan Then
ChiaKeo = IIf(SL = True, SoLuongCan + Rng.Offset(, CotSoLuong - 1).Value - Tong, Rng.Value)
ElseIf TT = K + 1 And Tong < SoLuongCan Then
ChiaKeo = IIf(SL = True, Tong - SoLuongCan, QuyCachCan)
End If
End Function------Sa_DQ đã viết:
Function ChiaKeo(QuyCachCan As String, SoLuongCan As Double, BangQuyCach As Range, CotSoLuong As Byte, TT As Integer, Optional SL As Boolean = False) As String
Dim K As Integer, STT As Integer, Rng As Range, Tong As Double
Dim QuyCach() As Variant
STT = 0
K = Application.WorksheetFunction.CountIf(BangQuyCach.Resize(, 1), QuyCachCan & "*")
ReDim Preserve QuyCach(K - 1)
For Each cll In BangQuyCach.Resize(, 1)
If InStr(cll.Value, QuyCachCan) > 0 Then
QuyCach(STT) = CInt(Right(cll.Value, Len(cll.Value) - InStr(cll.Value, "-")))
STT = STT + 1
End If
Next
For i = 1 To K
Set Rng = BangQuyCach.Resize(, 1).Find(what:=QuyCachCan & "-" & Application.WorksheetFunction.Small(QuyCach(), i), After:=BangQuyCach.Cells(BangQuyCach.Rows.Count, 1), LookAt:=xlWhole)
Tong = Tong + Rng.Offset(, CotSoLuong - 1).Value
If Tong >= SoLuongCan Then
K = i
Exit For
End If
Next
If TT <= K Then Set Rng = BangQuyCach.Resize(, 1).Find(what:=QuyCachCan & "-" & Application.WorksheetFunction.Small(QuyCach(), TT), LookAt:=xlWhole)
If TT < K Or (TT = K And Tong <= SoLuongCan) Then
ChiaKeo = IIf(SL = True, Rng.Offset(, CotSoLuong - 1).Value, Rng.Value)
ElseIf TT = K And Tong > SoLuongCan Then
ChiaKeo = IIf(SL = True, SoLuongCan + Rng.Offset(, CotSoLuong - 1).Value - Tong, Rng.Value)
ElseIf TT = K + 1 And Tong < SoLuongCan Then
ChiaKeo = IIf(SL = True, Tong - SoLuongCan, QuyCachCan)
End If
End Function
Với yêu cầu này mà dùng hàm thì tôi thấy không hợp lý lắm. Sao không dùng Macro cho đơn giản.
Option Explicit: Option Base 1
Function PhatKeo(LookUpRange As Range, QuiCach As String, SoLuong As Long)
Dim Temp, Clls As Range, Rng As Range, LRng As Range
Dim Dem As Byte, DDai As Byte, Rws As Long, Con As Long
Rws = LookUpRange.Rows.Count: ReDim MDL(Rws, 2)
ReDim KKK(Rws) As Long: DDai = Len(QuiCach)
Set LRng = LookUpRange.Cells(1, 1).Resize(Rws)
For Each Clls In LRng
If InStr(Clls.Value, QuiCach) > 0 Then
Dem = Dem + 1
KKK(Dem) = Right(Clls.Value, Len(Clls.Value) - DDai - 1)
End If
Next Clls
DDai = 0
Do
DDai = DDai + 1
For Con = 1 To (Dem - 1)
If KKK(Con) > KKK(Con + 1) Then
Temp = KKK(Con): KKK(Con) = KKK(Con + 1)
KKK(Con + 1) = Temp
End If
Next Con
Loop While DDai < 7
Con = 0
For Rws = 1 To Dem
Set Clls = LRng.Find(QuiCach & "-" & CStr(KKK(Rws)), , xlFormulas, xlWhole)
If Not Clls Is Nothing Then
MDL(Rws, 1) = Clls.Value
Con = Clls.Offset(, 2).Value
If Con <= SoLuong Then
MDL(Rws, 2) = Con
SoLuong = SoLuong - Con
Else
MDL(Rws, 2) = SoLuong: SoLuong = 0
Exit For
End If
End If
Next Rws
If SoLuong > 0 Then
' Rws = 1 + Rws '
MDL(Rws, 1) = QuiCach: MDL(Rws, 2) = -SoLuong
End If
PhatKeo = MDL
End Function
với "GOM KẸO", thành thật xin lỗi.
Tôi viết UDF mà quên hướng dẫn bạn cú pháp. Sơ xuất quá. Để tôi giải thích sơ sơ về cú pháp của hàm này:Tôi biết bạn mệt
Hàm của bạn "ngộ" quá tôi không hiểu nổi, nhưng thấy có lý và thực tế lắm.
Tôi đứng trong file của bạn, nhưng từ 1 sheet khác, cùng 1 vị trí, gọi hàm và được kết quả:
E7=ChiaKeo($E$4,$F$4,ChiaKeo!$A$3:$A$10,3,ROW(A1))
F7=ChiaKeo($E$4,$F$4,ChiaKeo!$A$3:$A$10,3,ROW(A1),1)
Nhờ bạn hướng dẫn:
$A$3:$A$10 : Vùng trong cột chứa quy cách ? (a)
3 : Cột thứ 3 tính từ cột chứa quy cách ? (b)
ROW(A1),ROW(A1),1 là sao ? (c)
* Có cách nào khắc phục, hoặc làm thế nào chứ không lẽ fill công thức từ A1:A theo dòng chứa quy cách ( thực tế >= 3000 dòng ) , giải quyết được vấn đề này thì khả thi hơn, không biết viết như thế bạn có hiểu không ?
Mong tin bạn.
=ChiaKeo(MaQuyCach,SoLuong,BangTonKho,CotSoLuong,ThuTuKien,[SL])------
Rất mong bạn xem file đính kèm sẻ rõ hơn =>
Đúng. Vì là công thức nên kết quả chỉ trả về ô bạn nhập công thức. Các ô bên dưới bạn phải fill bằng tay.
Lúc khai báo hàm tôi không để ý. Xóa khai báo kiểu dữ liệu của ChiaKeo là được. Đã sửa lại trong file.
Tôi dùng Excel 2007 và thấy nhập bình thường mà. Bạn kiểm tra lại xem. Kéo thanh Scrol bên phải xuống xem có không.
Trên thanh fx
fx=ChiaKeo($E$4,$F$4,$A$3:$C$31,3[B],"ROW(A1),2",[/B]2) => Tự điền vào dấu nháy
Gía trị cell
D7= #VALUE
