Code VBA tìm mã kiện gỗ còn tồn kho (1 người xem)

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
Tôi tuân thủ nội quy khi đăng bài
Có
M

moihocvba

Thành viên thường trực
Tham gia
16/8/20
Bài viết
214
Được thích
51
Em chào anh chị, em làm bên nhập xuất kho kiện gỗ, em cần danh sách các kiện còn tồn trong kho khi so sanh giữa bảng nhập và bảng xuất, biết rằng các kiện có thể trùng tên nhau, ví dụ bảng nhập Mặt hàng A có 2 kiện 120A, khi xuất đi 1 kiện 120A thì tồn kho sẽ còn tồn 1 kiện 120A (không phân biệt thứ tự số trước sau)

Kết quả mà em cần nó hiển thị ở phần màu vàng như hình em minh họa, anh chị có thể giúp em code vba với ạ, em xin cám ơn nhiều ạ!
Em cần giúp code vì bảng nhập và xuất có hàng ngàn dòng nên phải dùng code mới nhanh ạ, anh chị làm demo trên dữ liệu em gửi, em về em tập chỉnh lại như file của em ạ.

1735011686272.png
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
moihocvba đã viết:
Em chào anh chị, em làm bên nhập xuất kho kiện gỗ, em cần danh sách các kiện còn tồn trong kho khi so sanh giữa bảng nhập và bảng xuất, biết rằng các kiện có thể trùng tên nhau, ví dụ bảng nhập Mặt hàng A có 2 kiện 120A, khi xuất đi 1 kiện 120A thì tồn kho sẽ còn tồn 1 kiện 120A (không phân biệt thứ tự số trước sau)

Kết quả mà em cần nó hiển thị ở phần màu vàng như hình em minh họa, anh chị có thể giúp em code vba với ạ, em xin cám ơn nhiều ạ!
Em cần giúp code vì bảng nhập và xuất có hàng ngàn dòng nên phải dùng code mới nhanh ạ, anh chị làm demo trên dữ liệu em gửi, em về em tập chỉnh lại như file của em ạ.

View attachment 306439
Nhấp chuột vào đây để mở rộng...
Dòng A11 có phải là 123A không? bạn xem lại.
Nếu Các ô tô vàng là các mã kiện duy nhất thì tham khảo code củ chuối sau:

Mã: 
Option Explicit

Sub TonKho()
Dim i&, j&, Lr&, t&, k&
Dim ArrN(), ArrX(), KQ(), S
Dim Dic As Object, Key
Set Dic = CreateObject("Scripting.Dictionary")

With Sheet1
Lr = .Range("A100000").End(xlUp).Row
ArrN = .Range("A4:D" & Lr).Value
ReDim KQ(1 To UBound(ArrN) * 3, 1 To 2)
Lr = .Range("F100000").End(xlUp).Row
ArrX = .Range("F4:I" & Lr).Value
End With

For i = 1 To UBound(ArrN)
    For j = 2 To UBound(ArrN, 2)
        If ArrN(i, j) <> Empty Then
            Key = ArrN(i, 1) & "#" & ArrN(i, j)
            If Not Dic.Exists(Key) Then
                t = t + 1: Dic.Add (Key), t
                Dic(Key) = 1
            Else
                Dic(Key) = Dic(Key) + 1
            End If
        End If
    Next j
Next i

For i = 1 To UBound(ArrX)
    For j = 2 To UBound(ArrX, 2)
        If ArrX(i, j) <> Empty Then
            Key = ArrX(i, 1) & "#" & ArrX(i, j)
            If Dic.Exists(Key) Then
                S = Split(Dic(Key), "|")
                If UBound(S) = 0 Then
                    Dic(Key) = Dic(Key) & "|" & 1
                Else
                    Dic(Key) = Dic(Key) & "|" & S(1) + 1
                End If
            End If
        End If
    Next j
Next i
For Each Key In Dic.Keys
    S = Split(Dic(Key), "|")
        If UBound(S) > 0 Then
            If S(0) - S(1) > 0 Then
                k = k + 1
                KQ(k, 1) = Split(Key, "#")(0)
                KQ(k, 2) = Split(Key, "#")(1)
            End If
        Else
            k = k + 1
                KQ(k, 1) = Split(Key, "#")(0)
                KQ(k, 2) = Split(Key, "#")(1)
        End If
Next Key
Sheet2.Range("C2").Resize(k, 2) = KQ
End Sub
Xem file
 

File đính kèm

Upvote 0
moihocvba đã viết:
Em chào anh chị, em làm bên nhập xuất kho kiện gỗ, em cần danh sách các kiện còn tồn trong kho khi so sanh giữa bảng nhập và bảng xuất, biết rằng các kiện có thể trùng tên nhau, ví dụ bảng nhập Mặt hàng A có 2 kiện 120A, khi xuất đi 1 kiện 120A thì tồn kho sẽ còn tồn 1 kiện 120A (không phân biệt thứ tự số trước sau)

Kết quả mà em cần nó hiển thị ở phần màu vàng như hình em minh họa, anh chị có thể giúp em code vba với ạ, em xin cám ơn nhiều ạ!
Em cần giúp code vì bảng nhập và xuất có hàng ngàn dòng nên phải dùng code mới nhanh ạ, anh chị làm demo trên dữ liệu em gửi, em về em tập chỉnh lại như file của em ạ.

View attachment 306439
Nhấp chuột vào đây để mở rộng...
Mượn file của bạn @HUONGHCKT, chạy code
Mã: 
Sub xyz()
  Dim aNhap(), aXuat(), res(), S, Dic As Object, key$
  Dim i&, j&, k&
 
  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheet1
    aNhap = .Range("A4:D" & .Range("A100000").End(xlUp).Row).Value
    ReDim res(1 To UBound(aNhap) * (UBound(aNhap, 2) - 1), 1 To 2)
    aXuat = .Range("F4:I" & .Range("F100000").End(xlUp).Row).Value
  End With

  For i = 1 To UBound(aXuat)
    If aXuat(i, 1) <> Empty Then
      For j = 2 To UBound(aXuat, 2)
        If aXuat(i, j) <> Empty Then
          key = aXuat(i, 1) & "|" & aXuat(i, j)
          Dic(key) = Dic(key) + 1
        End If
      Next j
    End If
  Next i

  For i = 1 To UBound(aNhap)
    If aNhap(i, 1) <> Empty Then
      For j = 2 To UBound(aNhap, 2)
        If aNhap(i, j) <> Empty Then
          key = aNhap(i, 1) & "|" & aNhap(i, j)
          If Dic.Exists(key) Then
            Dic(key) = Dic(key) - 1
            If Dic(key) = 0 Then Dic.Remove (key)
          Else
            k = k + 1
            res(k, 1) = aNhap(i, 1)
            res(k, 2) = aNhap(i, j)
          End If
        End If
      Next j
    End If
  Next i
  Sheet2.Range("C2").Resize(k, 2) = res
End Sub
 
Upvote 0
HUONGHCKT đã viết:
Dòng A11 có phải là 123A không? bạn xem lại.
Nếu Các ô tô vàng là các mã kiện duy nhất thì tham khảo code củ chuối sau:

Mã: 
Option Explicit

Sub TonKho()
Dim i&, j&, Lr&, t&, k&
Dim ArrN(), ArrX(), KQ(), S
Dim Dic As Object, Key
Set Dic = CreateObject("Scripting.Dictionary")

With Sheet1
Lr = .Range("A100000").End(xlUp).Row
ArrN = .Range("A4:D" & Lr).Value
ReDim KQ(1 To UBound(ArrN) * 3, 1 To 2)
Lr = .Range("F100000").End(xlUp).Row
ArrX = .Range("F4:I" & Lr).Value
End With

For i = 1 To UBound(ArrN)
    For j = 2 To UBound(ArrN, 2)
        If ArrN(i, j) <> Empty Then
            Key = ArrN(i, 1) & "#" & ArrN(i, j)
            If Not Dic.Exists(Key) Then
                t = t + 1: Dic.Add (Key), t
                Dic(Key) = 1
            Else
                Dic(Key) = Dic(Key) + 1
            End If
        End If
    Next j
Next i

For i = 1 To UBound(ArrX)
    For j = 2 To UBound(ArrX, 2)
        If ArrX(i, j) <> Empty Then
            Key = ArrX(i, 1) & "#" & ArrX(i, j)
            If Dic.Exists(Key) Then
                S = Split(Dic(Key), "|")
                If UBound(S) = 0 Then
                    Dic(Key) = Dic(Key) & "|" & 1
                Else
                    Dic(Key) = Dic(Key) & "|" & S(1) + 1
                End If
            End If
        End If
    Next j
Next i
For Each Key In Dic.Keys
    S = Split(Dic(Key), "|")
        If UBound(S) > 0 Then
            If S(0) - S(1) > 0 Then
                k = k + 1
                KQ(k, 1) = Split(Key, "#")(0)
                KQ(k, 2) = Split(Key, "#")(1)
            End If
        Else
            k = k + 1
                KQ(k, 1) = Split(Key, "#")(0)
                KQ(k, 2) = Split(Key, "#")(1)
        End If
Next Key
Sheet2.Range("C2").Resize(k, 2) = KQ
End Sub
Xem file
Nhấp chuột vào đây để mở rộng...
Mã kiện có thể trùng nhau ạ! Không nhất thiết phải là duy nhất!
Bài đã được tự động gộp:

HieuCD đã viết:
Mượn file của bạn @HUONGHCKT, chạy code
Mã: 
Sub xyz()
  Dim aNhap(), aXuat(), res(), S, Dic As Object, key$
  Dim i&, j&, k&
 
  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheet1
    aNhap = .Range("A4:D" & .Range("A100000").End(xlUp).Row).Value
    ReDim res(1 To UBound(aNhap) * (UBound(aNhap, 2) - 1), 1 To 2)
    aXuat = .Range("F4:I" & .Range("F100000").End(xlUp).Row).Value
  End With

  For i = 1 To UBound(aXuat)
    If aXuat(i, 1) <> Empty Then
      For j = 2 To UBound(aXuat, 2)
        If aXuat(i, j) <> Empty Then
          key = aXuat(i, 1) & "|" & aXuat(i, j)
          Dic(key) = Dic(key) + 1
        End If
      Next j
    End If
  Next i

  For i = 1 To UBound(aNhap)
    If aNhap(i, 1) <> Empty Then
      For j = 2 To UBound(aNhap, 2)
        If aNhap(i, j) <> Empty Then
          key = aNhap(i, 1) & "|" & aNhap(i, j)
          If Dic.Exists(key) Then
            Dic(key) = Dic(key) - 1
            If Dic(key) = 0 Then Dic.Remove (key)
          Else
            k = k + 1
            res(k, 1) = aNhap(i, 1)
            res(k, 2) = aNhap(i, j)
          End If
        End If
      Next j
    End If
  Next i
  Sheet2.Range("C2").Resize(k, 2) = res
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn anh nhiều!
Code này chạy gần đúng rồi, chỉ có 1 cái là mặt hàng A có 2 mã kiện 123A thì nó phải thể hiện đúng cả 2 mã kiện luôn. Nhập 6 kiện, xuất 2 kiện thì còn 4 kiện (kể cả trùng nhau)
1735092208689.png

Với anh sửa lại giúp em, ví dụ ô C1 sheet2 em nhập mã kiện A, khi chạy code thì nó chỉ hiện thị tồn kho của mặt hàng A, vì em cần lọc theo từng mặt hàng, như hình này ạ!

1735092308396.png

Em xin chân thành cảm ơn ạ!
 
Upvote 0
moihocvba đã viết:
Mã kiện có thể trùng nhau ạ! Không nhất thiết phải là duy nhất!
Bài đã được tự động gộp:


Cám ơn anh nhiều!
Code này chạy gần đúng rồi, chỉ có 1 cái là mặt hàng A có 2 mã kiện 123A thì nó phải thể hiện đúng cả 2 mã kiện luôn. Nhập 6 kiện, xuất 2 kiện thì còn 4 kiện (kể cả trùng nhau)


Với anh sửa lại giúp em, ví dụ ô C1 sheet2 em nhập mã kiện A, khi chạy code thì nó chỉ hiện thị tồn kho của mặt hàng A, vì em cần lọc theo từng mặt hàng, như hình này ạ!



Em xin chân thành cảm ơn ạ!
Nhấp chuột vào đây để mở rộng...
Chỉnh lại tí xíu .
Mã: 
Option Explicit

Sub xyz()
  Dim aNhap(), aXuat(), res(), S, Dic As Object, key$, mh$
  Dim i&, j&, k&
 
  Set Dic = CreateObject("Scripting.Dictionary")
  mh = Sheets("Sheet2").Range("D1").Value
  With Sheets("Sheet1")
    aNhap = .Range("A4:D" & .Range("A100000").End(xlUp).Row).Value
    ReDim res(1 To UBound(aNhap) * (UBound(aNhap, 2) - 1), 1 To 1)
    aXuat = .Range("F4:I" & .Range("F100000").End(xlUp).Row).Value
  End With

  For i = 1 To UBound(aXuat)
    If aXuat(i, 1) = mh Then
      For j = 2 To UBound(aXuat, 2)
        If aXuat(i, j) <> Empty Then
          key = aXuat(i, 1) & "|" & aXuat(i, j)
          Dic(key) = Dic(key) + 1
        End If
      Next j
    End If
  Next i

  For i = 1 To UBound(aNhap)
    If aNhap(i, 1) = mh Then
      For j = 2 To UBound(aNhap, 2)
        If aNhap(i, j) <> Empty Then
          key = aNhap(i, 1) & "|" & aNhap(i, j)
          If Dic.Exists(key) Then
            Dic(key) = Dic(key) - 1
            If Dic(key) = 0 Then Dic.Remove (key)
          Else
            k = k + 1
            res(k, 1) = aNhap(i, j)
          End If
        End If
      Next j
    End If
  Next i
  With Sheets("Sheet2")
    i = .Range("D1000000").End(xlUp).Row
    If i > 1 Then .Range("D2:D" & i).Clear
    .Range("D2").Resize(k) = res
  End With
End Sub
 

File đính kèm

Upvote 0
HieuCD đã viết:
Chỉnh lại tí xíu .
Mã: 
Option Explicit

Sub xyz()
  Dim aNhap(), aXuat(), res(), S, Dic As Object, key$, mh$
  Dim i&, j&, k&
 
  Set Dic = CreateObject("Scripting.Dictionary")
  mh = Sheets("Sheet2").Range("D1").Value
  With Sheets("Sheet1")
    aNhap = .Range("A4:D" & .Range("A100000").End(xlUp).Row).Value
    ReDim res(1 To UBound(aNhap) * (UBound(aNhap, 2) - 1), 1 To 1)
    aXuat = .Range("F4:I" & .Range("F100000").End(xlUp).Row).Value
  End With

  For i = 1 To UBound(aXuat)
    If aXuat(i, 1) = mh Then
      For j = 2 To UBound(aXuat, 2)
        If aXuat(i, j) <> Empty Then
          key = aXuat(i, 1) & "|" & aXuat(i, j)
          Dic(key) = Dic(key) + 1
        End If
      Next j
    End If
  Next i

  For i = 1 To UBound(aNhap)
    If aNhap(i, 1) = mh Then
      For j = 2 To UBound(aNhap, 2)
        If aNhap(i, j) <> Empty Then
          key = aNhap(i, 1) & "|" & aNhap(i, j)
          If Dic.Exists(key) Then
            Dic(key) = Dic(key) - 1
            If Dic(key) = 0 Then Dic.Remove (key)
          Else
            k = k + 1
            res(k, 1) = aNhap(i, j)
          End If
        End If
      Next j
    End If
  Next i
  With Sheets("Sheet2")
    i = .Range("D1000000").End(xlUp).Row
    If i > 1 Then .Range("D2:D" & i).Clear
    .Range("D2").Resize(k) = res
  End With
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ kết quả đúng rồi ạ, em xin chân thành cảm ơn anh!
 
Upvote 0
nhờ anh chị giúp chỉnh code này. Tôi học từ anh chị nhưng chưa còn rất yếu. Anh chị giúp mình thực hiện 2 sheet: TH và Doanhthu. Tổng hợp từ ngày đến ngày?giúp đở.png
 

File đính kèm

Upvote 0
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

micam111
  • Question Question
Cách chạy nhiều đồng hồ đếm giờ trong VBA (1 người xem)
Trả lời
2
Đọc
595
tranduc36
T
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện.
Trả lời
13
Đọc
103
Hoàng Tuấn 868
H
1
Hỏi về đánh dấu hàng ngang hàng dọc bằng màu khi kích chuột vào 1 ô
Trả lời
7
Đọc
175
Gà Công Nghệ
Gà Công Nghệ
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt (1 người xem)
    • Thích
    • Yêu thích
2
Trả lời
20
Đọc
1K
Mr.hieudoanxd
Mr.hieudoanxd
P
Excell code vba : Tìm Cell để sửa dữ liệu
    • Buồn
2
Trả lời
26
Đọc
523
Phạm Trường 80
P
L
Lỗi font khi convert từ pdf
Trả lời
1
Đọc
56
Hoàng Tuấn 868
H
D
Nhờ anh em giúp đỡ.
    • Buồn
Trả lời
2
Đọc
77
SA_DQ
SA_DQ
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup (1 người xem)
Trả lời
2
Đọc
75
DeTong
D
H
Đổi số thành chữ trong office 365
Trả lời
19
Đọc
1K
HoangTan891026
H
Gà Công Nghệ
Lấy dữ liệu file excel từ sheet này sang sheet khác
Trả lời
4
Đọc
129
Gà Công Nghệ
Gà Công Nghệ
N
Mong mọi người giúp đỡ
Trả lời
1
Đọc
59
minhminh27
minhminh27
minhduc1o2
Excel lỗi font Time New Roman+
Trả lời
7
Đọc
116
minhduc1o2
minhduc1o2
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
0
Đọc
75
fujishima
F
H
Lọc dữ liệu trong XL
    • Cười
Trả lời
0
Đọc
46
huong.dinh
H
giaiphap
Add-Ins hổ trợ Word trộn danh sách và lưu ra nhiều tệp tin khác nhau.
    • Thích
    • Yêu thích
    • Cảm ơn
2
Trả lời
39
Đọc
9K
fujishima
F
K
xin file excel bảng đấu bóng đá (1 người xem)
    • Yêu thích
2 3
Trả lời
40
Đọc
25K
subin1905
S
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
24
Đọc
7K
chihuumvc
C
Trungvt3
Công thức trả về định dạng không như mong muốn và viết phân số trong 1 ô.
Trả lời
1
Đọc
66
bebo021999
B
G
Hướng dẫn Lập danh sách File
    • Không thích
Trả lời
16
Đọc
269
thanhhuy_hvnh
thanhhuy_hvnh
baolong240793
Nhờ Anh/Chị hỗ trợ em hàm Randbetween() với ạ.
Trả lời
4
Đọc
362
bebo021999
B
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom