Code Tính "Ton" và "TongHop" (1 người xem)

Liên hệ QC

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

NguyenthiH

Thành viên mới đăng ký
Tham gia
11/12/16
Bài viết
965
Được thích
175
Giới tính
Nữ
Chào mọi người em có file này nhờ mọi người viết Code để tính "Ton" sheet!Ton và Code tình "TongHop" sheet!TongHop.
Trong file mong mọi người mở Sheet!Ton và Sheet!TongHop ra, em có ghi chú cách tính trong 2 Sheet đó ah.
Mong các mọi người giúp đỡ
 

File đính kèm

Lần chỉnh sửa cuối:
Chào mọi người em có file này nhờ mọi người viết Code để tính "Ton" sheet!Ton và Code tình "TongHop" sheet!TongHop.
Trong file mong mọi người mở Sheet!Ton và Sheet!TongHop ra, em có ghi chú cách tính trong 2 Sheet đó ah.
Mong các mọi người giúp đỡ

Bạn kiểm tra lại kết quả file này xem sao nhé.
 

File đính kèm

Upvote 0
Chào mọi người em có file này nhờ mọi người viết Code để tính "Ton" sheet!Ton và Code tình "TongHop" sheet!TongHop.
Trong file mong mọi người mở Sheet!Ton và Sheet!TongHop ra, em có ghi chú cách tính trong 2 Sheet đó ah.
Mong các mọi người giúp đỡ
chạy thử code
Mã:
Public Sub Ton()
Dim Narr(), Xarr(), Arr(), i As Long, k As Long, R As Long, Tmp As String
With CreateObject("Scripting.Dictionary")
  With Sheets("Nhap")
    Narr = .Range("B2", .Range("B2").End(xlDown)).Resize(, 4).Value
  End With
  With Sheets("Xuat")
    Xarr = .Range("D2", .Range("D2").End(xlDown)).Resize(, 4).Value
  End With
  ReDim Arr(1 To UBound(Narr) + UBound(Xarr), 1 To 6)
  For i = 1 To UBound(Narr)
    Tmp = Narr(i, 1) & "#" & Narr(i, 2) & "#" & Narr(i, 4)
    If Not .Exists(Tmp) Then
      k = k + 1: .Add Tmp, k
      Arr(k, 1) = Narr(i, 1): Arr(k, 2) = Narr(i, 2)
      Arr(k, 3) = Narr(i, 3): Arr(k, 5) = Narr(i, 3)
      Arr(k, 6) = Narr(i, 4)
    Else
      R = .Item(Tmp)
      Arr(R, 3) = Arr(R, 3) + Narr(i, 3)
      Arr(R, 5) = Arr(R, 3)
    End If
  Next i
  For i = 1 To UBound(Xarr)
    Tmp = Xarr(i, 1) & "#" & Xarr(i, 2) & "#" & Xarr(i, 4)
    If Not .Exists(Tmp) Then
      k = k + 1: .Add Tmp, k
      Arr(k, 1) = Xarr(i, 1): Arr(k, 2) = Xarr(i, 2)
      Arr(k, 4) = Xarr(i, 3): Arr(k, 5) = Arr(k, 5) - Xarr(i, 3)
      Arr(k, 6) = Xarr(i, 4)
    Else
      R = .Item(Tmp)
      Arr(R, 4) = Arr(R, 4) + Xarr(i, 3)
      Arr(R, 5) = Arr(R, 5) - Xarr(i, 3)
    End If
  Next i
End With
With Sheets("Ton")
  .Range("A2:F10000").ClearContents
  .Range("A2").Resize(k, 6) = Arr
End With
End Sub
Public Sub TongHop()
Dim Narr(), Xarr(), Arr(), i As Long, k As Long, R As Long, Tmp As String
With CreateObject("Scripting.Dictionary")
  With Sheets("Nhap")
    Narr = .Range("B2", .Range("B2").End(xlDown)).Resize(, 3).Value
  End With
  With Sheets("Xuat")
    Xarr = .Range("D2", .Range("D2").End(xlDown)).Resize(, 3).Value
  End With
  ReDim Arr(1 To UBound(Narr) + UBound(Xarr), 1 To 5)
  For i = 1 To UBound(Narr)
    Tmp = Narr(i, 1) & "#" & Narr(i, 2)
    If Not .Exists(Tmp) Then
      k = k + 1: .Add Tmp, k
      Arr(k, 1) = Narr(i, 1): Arr(k, 2) = Narr(i, 2)
      Arr(k, 3) = Narr(i, 3): Arr(k, 5) = Narr(i, 3)
    Else
      R = .Item(Tmp)
      Arr(R, 3) = Arr(R, 3) + Narr(i, 3)
      Arr(R, 5) = Arr(R, 3)
    End If
  Next i
  For i = 1 To UBound(Xarr)
    Tmp = Xarr(i, 1) & "#" & Xarr(i, 2)
    If Not .Exists(Tmp) Then
      k = k + 1: .Add Tmp, k
      Arr(k, 1) = Xarr(i, 1): Arr(k, 2) = Xarr(i, 2)
      Arr(k, 4) = Xarr(i, 3): Arr(k, 5) = Arr(k, 5) - Xarr(i, 3)
    Else
      R = .Item(Tmp)
      Arr(R, 4) = Arr(R, 4) + Xarr(i, 3)
      Arr(R, 5) = Arr(R, 5) - Xarr(i, 3)
    End If
  Next i
End With
With Sheets("TongHop")
  .Range("A2:E10000").ClearContents
  .Range("A2").Resize(k, 5) = Arr
End With
End Sub
 
Upvote 0
Cám ơn Thầy Ba Tê và Anh HieuCD, em nhờ Thầy và Anh giúp em thêm trong Sheet!Ton :
1/khi chọn Đơn Hàng thì hiện tất cả SL tồn của đơn hang đó
2/khi chọn tên phụ lieu thì hiện SL tồn của phụ lieu đó.
 
Upvote 0
Em xin đưa File lên ah!
TRong File em có ví dụ trong Sheet!Ton và Sheet!ChiTiet.
Mong mọi người giúp đỡ.
 

File đính kèm

Upvote 0
Mong mọi người giúp em trong sheet!Ton và Sheet!ChiTiet với ah.
 
Upvote 0
Mong Anh HieuCD giúp em với(cũng giống các File khác mà Anh đã giúp em, nhưng thêm một số cột).
 
Upvote 0
Cám Ơn Anh HieuCD, code của anh chạy chưa đúng anh ơi.
Em ví dụ như chỏn "Nhãn Chính Novelty" trong C5(ComboBox1) thì G5(Của Đơn Hàng(ComBoBox2) là NKF16019-16020 nhưng số lieu nhập và xuất là của NKSF16009-16013, và em chọn tiếp đơn hang khác trong G5 thì code của anh không chạy.
Mong Anh xem giúp đỡ.
Code trước Anh làm cho em là trong form rồi đập vào Sheet.
 
Upvote 0
Xin lỗi code bài trước của anh cũng viết trên Sheet.
Code trong Sheet!ChiTiet
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$C$3" Then
    Call CreatListDH
  End If
  If Target.Address = "$E$3" Then
    Call Loc
  End If
End Sub
và code Loc trong Module
Mã:
Sub Loc()
Dim Darr(), Arr(1 To 1000, 1 To 6), PL As String, DH As String, Nhap As String, LastR As Long
PL = Range("C3").Value: DH = Replace(Range("E3").Value, ";", ","): Nhap = Range("D5").Value
'Trich du lieu Nhap
LastR = Sheets("Nhap").Range("A65500").End(xlUp).Row
If LastR > 1 Then
  Darr = Sheets("Nhap").Range("A2:E" & LastR).Value
  For i = 1 To UBound(Darr)
    If DH = Darr(i, 2) And PL = Darr(i, 3) Then
      k = k + 1
      Arr(k, 2) = Darr(i, 1): Arr(k, 3) = Nhap
      Arr(k, 4) = Darr(i, 5): Arr(k, 6) = 1
    End If
  Next i
End If
'Trich du lieu Xuat
LastR = Sheets("Xuat").Range("A65500").End(xlUp).Row
If LastR > 1 Then
  Darr = Sheets("Xuat").Range("A2:F" & LastR).Value
  For i = 1 To UBound(Darr)
    If DH = Darr(i, 2) And PL = Darr(i, 3) Then
      k = k + 1
      Arr(k, 2) = Darr(i, 1): Arr(k, 3) = Darr(i, 5)
      Arr(k, 5) = Darr(i, 6): Arr(k, 6) = 2
    End If
  Next i
End If
'Gan ket qua
Range("A6:F1000").ClearContents
Range("A6:F1000").Borders.LineStyle = xlNone
If k Then
  Range("A6").Resize(k, 6) = Arr
  Range("A5").Resize(k + 1, 6).Sort [B5], 1, [D5], , 2, Header:=xlYes
  Darr = Range("A6").Resize(k, 6).Value
  Darr(1, 1) = 1:  Darr(1, 6) = Darr(1, 4) - Darr(1, 5)
  For i = 2 To k
    Darr(i, 1) = i:  Darr(i, 6) = Darr(i - 1, 6) + Darr(i, 4) - Darr(i, 5)
  Next i
  Range("A6").Resize(k, 6) = Darr
  Range("A6").Resize(k, 6).Borders.LineStyle = 1
  Range("D6").Resize(k, 3).NumberFormat = "#,##0.00_);[Red](-#,##0.00)"
End If
End Sub
Sub CreatListDH()
  Dim Darr(), Dic As Object, PL As String, i As Long, LastR As Long, DK
  LastR = Sheets("Ton").Range("B65500").End(xlUp).Row
  If LastR > 1 Then
    DK = Sheets("Chitiet").Range("C3").Value
    Darr = Sheets("Ton").Range("A2:B" & LastR).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Darr)
      If Darr(i, 2) = DK Then Dic(Darr(i, 1)) = ""
    Next
    Sheets("Chitiet").Range("J3:J1000").ClearContents
    Sheets("Chitiet").Range("J2").Resize(Dic.count) = Application.Transpose(Dic.keys)
    Sheets("Chitiet").Range("E3").Value = Range("J2").Value
  End If
  Set Dic = Nothing
End Sub
Sub CreatListPL()
  Dim Darr(), Dic As Object, i As Long, LastR As Long
  LastR = Sheets("Ton").Range("B65500").End(xlUp).Row
  If LastR > 1 Then
    Darr = Sheets("Ton").Range("B2:B" & LastR).Value
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Darr)
      Dic(Darr(i, 1)) = ""
    Next
    With Sheets("Chitiet")
      .Range("I3:I1000").ClearContents
      .Range("I2").Resize(Dic.count) = Application.Transpose(Dic.keys)
      .Range("I2").Resize(Dic.count).Sort .[I2], 1, Header:=xlNo
    End With
    Set Dic = Nothing
  End If
End Sub
Mong anh xem giúp.
 
Upvote 0
Cám Ơn Anh HieuCD, code của anh chạy chưa đúng anh ơi.
Em ví dụ như chỏn "Nhãn Chính Novelty" trong C5(ComboBox1) thì G5(Của Đơn Hàng(ComBoBox2) là NKF16019-16020 nhưng số lieu nhập và xuất là của NKSF16009-16013, và em chọn tiếp đơn hang khác trong G5 thì code của anh không chạy.
Mong Anh xem giúp đỡ.
Code trước Anh làm cho em là trong form rồi đập vào Sheet.
bạn sửa lại chổ màu đỏ
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$C$5" Or Target.Address = [COLOR=#ff0000]"$G$5"[/COLOR] Then
    Call ChiTietCreat
  End If
End Sub
 
Upvote 0
Được rồi Anh Ơi.
Cám ơn Anh nhiều.
ps: thế còn lọc trong Sheet!Ton
Mong Anh giúp.
 
Lần chỉnh sửa cuối:
Upvote 0
Mạng bị chậm hay sao ấy, bài của em đưa lên thì thầy bài của anh rồi.
Em đã có chỉnh lại ở bài #12 rồi.
Code cua3Anh đã chạy OK rồi.
Ah mà chưa ổn chổ này: nếu có nhập và xuất cùng ngày thì ưu tiên Nhập trước Xuất sau
Ví dụ như "Nhãn Chính Novelty" của đơn "NKSF16009-16013" cùng ngày "10/08/2016" có nhập là 730 và xuất 2815, code của anh đưa xuất 2815 trước nên bị âm(-)
Mong anh chỉnh giúp.
 
Upvote 0
Mạng bị chậm hay sao ấy, bài của em đưa lên thì thầy bài của anh rồi.
Em đã có chỉnh lại ở bài #12 rồi.
Code cua3Anh đã chạy OK rồi.
Ah mà chưa ổn chổ này: nếu có nhập và xuất cùng ngày thì ưu tiên Nhập trước Xuất sau
Ví dụ như "Nhãn Chính Novelty" của đơn "NKSF16009-16013" cùng ngày "10/08/2016" có nhập là 730 và xuất 2815, code của anh đưa xuất 2815 trước nên bị âm(-)
Mong anh chỉnh giúp.
bạn chỉnh lại
Mã:
Private Sub ChiTietCreat()
....
  If k Then
    Range("B9").Resize(k, 5) = Arr
[COLOR=#ff0000]    Range("B9:F9").Resize(k).Sort [B9], 1, [E9], , 2, Header:=xlNo[/COLOR]
    Range("A9").Value = 1
...
Mã:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
....
    If Target.Address = "$G$5" Then
[COLOR=#ff0000]      If Not IsArray(DHarr) Then Call DHCreatList:   ComboBox2.List = DHarr[/COLOR]
      ComboBox2.Visible = True
      ComboBox2.Activate
      ComboBox2.DropDown
    Else
....
 
Upvote 0
Cám ơn Anh HieuCD.
Ah mà sao em Double Click vào Combobox1 không được vậy anh?
Chỉ Click, mà Click thì không chạy code.
 
Upvote 0
Sao em thấy ComboBox trên Form thì khi SetForcus thì em gỏ từ nào vào thì nó tự xổ ra danh sách gần đúng, còn ComboBox trên sheet thì không được.
Mong mọi người có thể giúp em vấn đề này được không?
Tức là gỏ từ vào Combobox trên Sheet thì xổ ra danh sách gần đúng để chọn.
 
Upvote 0
Sao em thấy ComboBox trên Form thì khi SetForcus thì em gỏ từ nào vào thì nó tự xổ ra danh sách gần đúng, còn ComboBox trên sheet thì không được.
Mong mọi người có thể giúp em vấn đề này được không?
Tức là gỏ từ vào Combobox trên Sheet thì xổ ra danh sách gần đúng để chọn.
thử lại với toàn bộ code mới
Mã:
Dim PLarr As Variant, DHarr As Variant, TestPL As String, Dk As String


Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$G$5" Then
  Call ChiTietCreat
  End If
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address = "$C$5" Then
    ComboBox1.Visible = True
    ComboBox1.Activate
    ComboBox1.DropDown
  Else
    If ComboBox1.Visible = True Then
      ComboBox1.Visible = False
    End If
    If Target.Address = "$G$5" Then
      If Not IsArray(DHarr) Then Call DHCreatList:   ComboBox2.List = DHarr
      ComboBox2.Visible = True
      ComboBox2.Activate
      ComboBox2.DropDown
    Else
      If ComboBox2.Visible = True Then
        ComboBox2.Visible = False
      End If
    End If
  End If
End Sub


Private Sub ComboBox1_GotFocus()
  TestPL = Range("C5").Value
  If Not IsArray(PLarr) Then Call PLCreatList:  ComboBox1.List = PLarr
End Sub


Private Sub ComboBox1_Change()
  Dk = UCase(ComboBox1.Value)
  Call PLCreatList
  ComboBox1.List = PLarr
  ComboBox1.DropDown
End Sub


Private Sub ComboBox1_Click()
  Range("C5").Value = ComboBox1.Value
  Call CbBox1
End Sub


Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
  If KeyCode = 13 Then
    Range("C5").Value = ComboBox1.Value
    Call CbBox1
  End If
End Sub


Private Sub CbBox1()
    With ComboBox1
      If .MatchFound And TestPL <> .Value Then
        Range("E5").Value = PLarr(.ListIndex + 1, 2)
        Call DHCreatList
        TestPL = Range("C5").Value
        ComboBox2.List = DHarr
        ComboBox2.Value = ComboBox2.List(0)
        Range("G5").Value = ComboBox2.Value
      End If
    End With
    Range("C6").Select
End Sub


Private Sub ComboBox2_Change()
  Range("G5").Value = ComboBox2.Value
End Sub


Private Sub ComboBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  Range("C6").Select
End Sub


Private Sub ComboBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then Range("C6").Select
End Sub


Private Sub ChiTietCreat()
  Dim Narr(), Xarr(), Arr(), i As Long, k As Long, nh As String, dk1 As String, dk2 As String
  dk1 = Range("C5").Value:  dk2 = Range("G5").Value
  With Sheets("Nhap")
    Narr = .Range("A2", .Range("B2").End(xlDown)).Resize(, 5).Value
    nh = Left(.Range("E1").Value, 4) & "-"
  End With
  With Sheets("Xuat")
    Xarr = .Range("A2", .Range("D2").End(xlDown)).Resize(, 7).Value
  End With
  ReDim Arr(1 To UBound(Narr) + UBound(Xarr), 1 To 5)
  For i = 1 To UBound(Narr)
    If dk1 = Narr(i, 2) And dk2 = Narr(i, 5) Then
      k = k + 1
      Arr(k, 1) = Narr(i, 1):       Arr(k, 3) = Narr(i, 1)
      Arr(k, 2) = nh & Narr(i, 5):  Arr(k, 4) = Narr(i, 4)
    End If
  Next i
  For i = 1 To UBound(Xarr)
    If dk1 = Xarr(i, 4) And dk2 = Xarr(i, 7) Then
      k = k + 1
      Arr(k, 1) = Xarr(i, 1):       Arr(k, 3) = Xarr(i, 1)
      Arr(k, 2) = Xarr(i, 2) & " " & Xarr(i, 3): Arr(k, 5) = Xarr(i, 6)
    End If
  Next i
  Range("A9:G" & 1000).Borders.LineStyle = 0
  Range("A9:G" & 1000).ClearContents
  If k Then
    Range("B9").Resize(k, 5) = Arr
    Range("B9:F9").Resize(k).Sort [B9], 1, [E9], , 2, Header:=xlNo
    Range("A9").Value = 1
    Range("A9").Resize(k).DataSeries
    Range("A9:G9").Resize(k).Borders.LineStyle = 1
    Range("B9").Resize(k).NumberFormat = "dd/mm/yyyy"
    Range("D9").Resize(k).NumberFormat = "dd/mm/yyyy"
    Range("E9").Resize(k, 3).NumberFormat = " #,##0 ;[red]( #,##0 )"
    Range("G9").Value = Range("E9").Value - Range("F9").Value
    If k > 1 Then
      For i = 10 To 8 + k
        Range("G" & i) = Range("G" & i - 1) + Range("E" & i) - Range("F" & i)
      Next i
    End If
  End If
End Sub


Private Sub PLCreatList()
  Dim Narr(), Xarr(), oList As Object, i As Long, Tmp As Variant
  With Sheets("Nhap")
    Narr = .Range("B2", .Range("B2").End(xlDown)).Resize(, 2).Value
  End With
  With Sheets("Xuat")
    Xarr = .Range("D2", .Range("D2").End(xlDown)).Resize(, 2).Value
  End With
  Set oList = CreateObject("System.Collections.ArrayList")
  For i = 1 To UBound(Narr)
    Tmp = Narr(i, 1) & "#" & Narr(i, 2)
    If UCase(Tmp) Like Dk & "*" Or Dk = "" Then
      If Len(Tmp) Then
        If Not oList.Contains(Tmp) Then oList.Add Tmp
      End If
    End If
  Next i
  For i = 1 To UBound(Xarr)
    Tmp = Xarr(i, 1) & "#" & Xarr(i, 2)
    If UCase(Tmp) Like Dk & "*" Or Dk = "" Then
      If Len(Tmp) Then
        If Not oList.Contains(Tmp) Then oList.Add Tmp
      End If
    End If
  Next i
  oList.Sort
  If oList.Count Then
  ReDim PLarr(1 To oList.Count, 1 To 2)
  For i = 0 To oList.Count - 1
    Tmp = Split(oList(i), "#")
    PLarr(i + 1, 1) = Tmp(0): PLarr(i + 1, 2) = Tmp(1)
  Next i
  End If
End Sub


Private Sub DHCreatList()
  Dim Narr(), Xarr(), sList As Object, i As Long, Tmp As Variant
  With Sheets("Nhap")
    Narr = .Range("B2", .Range("B2").End(xlDown)).Resize(, 4).Value
  End With
  With Sheets("Xuat")
    Xarr = .Range("D2", .Range("D2").End(xlDown)).Resize(, 4).Value
  End With
  Set sList = CreateObject("System.Collections.ArrayList")
  For i = 1 To UBound(Narr)
    If [C5].Value = Narr(i, 1) Then
      Tmp = Narr(i, 4)
      If Len(Tmp) Then
        If Not sList.Contains(Tmp) Then sList.Add Tmp
      End If
    End If
  Next i
  For i = 1 To UBound(Xarr)
    If [C5].Value = Xarr(i, 1) Then
      Tmp = Xarr(i, 4)
      If Len(Tmp) Then
        If Not sList.Contains(Tmp) Then sList.Add Tmp
      End If
    End If
  Next i
  sList.Sort
  ReDim DHarr(1 To sList.Count, 1 To 1)
  For i = 0 To sList.Count - 1
    DHarr(i + 1, 1) = sList(i)
  Next i
End Sub
 
Upvote 0
Em thử code mới của Anh thì thấy còn thua code cũ, khi dùng phím 40(xuống) thì nó chọn luôn, và khi chọn lần hai bằng click vào combobox1 thì nó lại không Dropdown,
Nói chung code cũ là được rồi chỉ không double click được thôi.(thì bỏ code Double click)
Trong code cũ tính sữa là :
Mã:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address = "$C$5" Then
    ComboBox1.Visible = True
    ComboBox1.Activate
    ComboBox1.DropDown
    [B][COLOR=#ff0000]ComboBox1.SelStart = 0
    ComboBox1.SelText = Len(.Text)  [/COLOR][/B][COLOR=#ff0000][/COLOR][COLOR=#0000ff]<- de phủ khối để gỏ từ vào tìm nhanh, nhưng không được[/COLOR]
  Else
    If ComboBox1.Visible = True Then
      ComboBox1.Visible = False
    End If
    If Target.Address = "$G$5" Then
      If Not IsArray(DHarr) Then Call DHCreatList:   ComboBox2.List = DHarr
      ComboBox2.Visible = True
      ComboBox2.Activate
      ComboBox2.DropDown
    Else
      If ComboBox2.Visible = True Then
        ComboBox2.Visible = False
      End If
    End If
  End If
End Sub
Mong Anh giúp.
 
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom