Giúp mình code VBA tách số lượng đóng gói

Liên hệ QC
nejisanta

nejisanta

Thành viên mới
Tham gia
27/2/20
Bài viết
4
Được thích
0
Dear All cho mình hỏi 1 chút với mình có 1 file như này:
Hiện tại mình đang cần là khi chạy code thì phần màu cam sẽ chạy theo điều kiện
+ Khi chạy dòng thứ 1 phần màu xanh
- Cột Q sẽ tính số lượg đóng theo từng pack, cột R sẽ là số pack tăng dần từ 1 đến roundup của cột F chia cho cột H ( Ví dụ như hình cột F là 102 cột H là 20 thì cột R sẽ là có 6 pack từ 1 đến 5 là 20, còn pack cuối cùng sẽ là 102-(5 pack * 20)= 2, pack thứ 6 sẽ là 2)
- Khi chạy xong dòng 1 thì dòng 2 sẽ chạy tiếp ở phần cột màu xanh
mình có viết code như sau, nhưng sai mong mọi người chỉ giúp mình với:


Sub tinhpack()
Dim i, k, lr, lrD, j, pack, p As Long
Dim arr(), arrD(), kq(), c As Integer
With Sheet4
lr = .Range("A" & Rows.Count).End(xlUp).Row
arr = .Range("A6:G" & lr).Value
End With
With Sheet5
lrD = .Range("A" & Rows.Count).End(xlUp).Row
arrD = .Range("A2:F" & lrD).Value
End With
ReDim kq(1 To 10000, 1 To 9)
For i = 1 To UBound(arrD, 1)
For j = 1 To UBound(arr, 1)
If arrD(i, 1) = arr(j, 2) Then
pack = WorksheetFunction.RoundUp(arr(j, 6) / arrD(i, 6), 0)
k = k + 1
For c = 1 To UBound(arr, 2)
'kq(k, c) = arr(j, c)
For d = 1 To WorksheetFunction.RoundUp(arr(j, 6) / arrD(i, 6), 0)
'p = p + 1
If pack > 0 Then
kq(d, 9) = d
kq(d, 8) = arrD(i, 6)
kq(d, c) = arr(j, c)
End If
Next d
Next c
End If
Next j
Next i
Sheet4.Range("J6:R3000").ClearContents
Sheet4.Range("J6").Resize(k, 9) = kq
End Sub


Capture.PNG
 

File đính kèm

nejisanta đã viết:
Dear All cho mình hỏi 1 chút với mình có 1 file như này:
Hiện tại mình đang cần là khi chạy code thì phần màu cam sẽ chạy theo điều kiện
+ Khi chạy dòng thứ 1 phần màu xanh
- Cột Q sẽ tính số lượg đóng theo từng pack, cột R sẽ là số pack tăng dần từ 1 đến roundup của cột F chia cho cột H ( Ví dụ như hình cột F là 102 cột H là 20 thì cột R sẽ là có 6 pack từ 1 đến 5 là 20, còn pack cuối cùng sẽ là 102-(5 pack * 20)= 2, pack thứ 6 sẽ là 2)
- Khi chạy xong dòng 1 thì dòng 2 sẽ chạy tiếp ở phần cột màu xanh
mình có viết code như sau, nhưng sai mong mọi người chỉ giúp mình với:


Sub tinhpack()
Dim i, k, lr, lrD, j, pack, p As Long
Dim arr(), arrD(), kq(), c As Integer
With Sheet4
lr = .Range("A" & Rows.Count).End(xlUp).Row
arr = .Range("A6:G" & lr).Value
End With
With Sheet5
lrD = .Range("A" & Rows.Count).End(xlUp).Row
arrD = .Range("A2:F" & lrD).Value
End With
ReDim kq(1 To 10000, 1 To 9)
For i = 1 To UBound(arrD, 1)
For j = 1 To UBound(arr, 1)
If arrD(i, 1) = arr(j, 2) Then
pack = WorksheetFunction.RoundUp(arr(j, 6) / arrD(i, 6), 0)
k = k + 1
For c = 1 To UBound(arr, 2)
'kq(k, c) = arr(j, c)
For d = 1 To WorksheetFunction.RoundUp(arr(j, 6) / arrD(i, 6), 0)
'p = p + 1
If pack > 0 Then
kq(d, 9) = d
kq(d, 8) = arrD(i, 6)
kq(d, c) = arr(j, c)
End If
Next d
Next c
End If
Next j
Next i
Sheet4.Range("J6:R3000").ClearContents
Sheet4.Range("J6").Resize(k, 9) = kq
End Sub


View attachment 251201
Nhấp chuột vào đây để mở rộng...
Bài này là bạn muốn lấy Số lượng 1 pack bên sheets STD Packing (nếu trùng Drawing ) .sau đó lấy đóng theo số lượng pack đã định thừa ra thì đóng riêng đúng không?
 
Cu Tồ đã viết:
Bài này là bạn muốn lấy Số lượng 1 pack bên sheets STD Packing (nếu trùng Drawing ) .sau đó lấy đóng theo số lượng pack đã định thừa ra thì đóng riêng đúng không?
Nhấp chuột vào đây để mở rộng...
Đúng rồi bạn ơi, ví dụ mã cần đóng hàng là 45, std packing là 10 thì sẽ đóng 4 thùng 10 và 1 thùng 5, sau khi kết thúc sẽ chuyển sang mã khác. Mình tự viết code mà k đc
Bài đã được tự động gộp:

befaint đã viết:
Tình trạng khai báo biến này là kiểu sao chép/ làm theo mấy anh chàng vê lốc đây.
Vài ba bữa lại thấy kiểu này.
Nhấp chuột vào đây để mở rộng...
Cái này mình tự quy định cho bản thân mình bạn ạ. Mìh ms học lên chỉ biết khai như thế cho nhanh, chưa biết khai loại dữ liệu nào cho tiết kiệm. OK
 
nejisanta đã viết:
ví dụ mã cần đóng hàng là 45, std packing là 10 thì sẽ đóng 4 thùng 10 và 1 thùng 5, sau khi kết thúc sẽ chuyển sang mã khác
Nhấp chuột vào đây để mở rộng...
File dựa vào sheets STD Packing để tra mã hàng.Nghĩa là là mã hàng ở cột B sheets Nhap du lieu có trong sheets STD Packing thì sẽ lấy STD Packing ở cột F sheets STD Packing ra tính (vì thấy trong file sheets này dữ liệu là dữ liệu được lọc duy nhất rồi)
 

File đính kèm

nejisanta đã viết:
Dear All cho mình hỏi 1 chút với mình có 1 file như này:
Hiện tại mình đang cần là khi chạy code thì phần màu cam sẽ chạy theo điều kiện
+ Khi chạy dòng thứ 1 phần màu xanh
- Cột Q sẽ tính số lượg đóng theo từng pack, cột R sẽ là số pack tăng dần từ 1 đến roundup của cột F chia cho cột H ( Ví dụ như hình cột F là 102 cột H là 20 thì cột R sẽ là có 6 pack từ 1 đến 5 là 20, còn pack cuối cùng sẽ là 102-(5 pack * 20)= 2, pack thứ 6 sẽ là 2)
- Khi chạy xong dòng 1 thì dòng 2 sẽ chạy tiếp ở phần cột màu xanh
mình có viết code như sau, nhưng sai mong mọi người chỉ giúp mình với:


Sub tinhpack()
Dim i, k, lr, lrD, j, pack, p As Long
Dim arr(), arrD(), kq(), c As Integer
With Sheet4
lr = .Range("A" & Rows.Count).End(xlUp).Row
arr = .Range("A6:G" & lr).Value
End With
With Sheet5
lrD = .Range("A" & Rows.Count).End(xlUp).Row
arrD = .Range("A2:F" & lrD).Value
End With
ReDim kq(1 To 10000, 1 To 9)
For i = 1 To UBound(arrD, 1)
For j = 1 To UBound(arr, 1)
If arrD(i, 1) = arr(j, 2) Then
pack = WorksheetFunction.RoundUp(arr(j, 6) / arrD(i, 6), 0)
k = k + 1
For c = 1 To UBound(arr, 2)
'kq(k, c) = arr(j, c)
For d = 1 To WorksheetFunction.RoundUp(arr(j, 6) / arrD(i, 6), 0)
'p = p + 1
If pack > 0 Then
kq(d, 9) = d
kq(d, 8) = arrD(i, 6)
kq(d, c) = arr(j, c)
End If
Next d
Next c
End If
Next j
Next i
Sheet4.Range("J6:R3000").ClearContents
Sheet4.Range("J6").Resize(k, 9) = kq
End Sub


View attachment 251201
Nhấp chuột vào đây để mở rộng...
Dùng Do ... Loop với điều kiện sản lượng
Mã: 
Sub ABC()
  Dim sArr(), Res(), Dic As Object
  Dim sRow&, i&, j&, k&, PNo&, Qty&, STD&
 
  Set Dic = CreateObject("Scripting.Dictionary")
  With Sheet5
    sArr = .Range("A2", .Range("F" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr)
    For i = 1 To sRow
      Dic.Item(sArr(i, 1)) = sArr(i, 6)
    Next
  End With
  ReDim Res(1 To 10000, 1 To 9)
  With Sheet4
    sArr = .Range("A6", .Range("G" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr)
    For i = 1 To sRow
      Qty = sArr(i, 6)
      STD = Dic.Item(sArr(i, 2))
      If Qty > 0 And STD > 0 Then
        PNo = 0
        Do
          k = k + 1
          For j = 1 To 7
            Res(k, j) = sArr(i, j)
          Next j
          If Qty > STD Then Res(k, 8) = STD Else Res(k, 8) = Qty
          PNo = PNo + 1:          Res(k, 9) = PNo
          Qty = Qty - STD
        Loop Until Qty <= 0
      End If
    Next i
    i = .Range("J" & Rows.Count).End(xlUp).Row
    If i > 5 Then .Range("J6:R" & i).ClearContents
    .Range("J6:R6").Resize(k) = Res
  End With
End Sub
 
Cu Tồ đã viết:
File dựa vào sheets STD Packing để tra mã hàng.Nghĩa là là mã hàng ở cột B sheets Nhap du lieu có trong sheets STD Packing thì sẽ lấy STD Packing ở cột F sheets STD Packing ra tính (vì thấy trong file sheets này dữ liệu là dữ liệu được lọc duy nhất rồi)
Nhấp chuột vào đây để mở rộng...
Thanks bác nhé, em còn 1 vấn đề nữa mà k có cách nào tra được. Như trong file này, Sheet DATABASE sẽ so sánh với giá trị của dictionary trong sheet Summary, nếu = thì bằng đã đóng hàng, nếu ít hơn thì là thừa, nhiều hơn là thiếu. Nhưng trong code mình viết, chỉ khi Order No ở cột B sheet Summary xuất hiện 2 lần trở lên thì mới so sánh với sheet DATABASE, xuát hiện 1 lần thì nó k so sánh. Bác giúp mình với ạ, Code mình như thế này:


Sub sosanhpack()
Dim i As Long, k As Long, j As Integer, OD As String, SL As Long, n As Long, key As Variant
Dim dic As Object, ODdic As String
Dim arr(), kq(), arrD(), kq2()
Set dic = CreateObject("scripting.dictionary")
'===========================================
With Sheet8
arrD = .Range("A3:R" & .Range("B" & Rows.Count).End(xlUp).Row).Value
ReDim kq2(1 To UBound(arrD, 1), 1 To UBound(arrD, 2))
End With
'===========================================
With Sheet1
arr = .Range("A2:P" & .Range("B" & Rows.Count).End(xlUp).Row).Value
ReDim kq(1 To UBound(arr, 1), 1 To UBound(arr, 2))
For i = 1 To UBound(arr, 1)
OD = arr(i, 2)
If arr(i, 11) = "Packed" Then
If Not dic.exists(OD) Then
k = k + 1
For j = 1 To UBound(arr, 2)
kq(k, 1) = arr(i, 2)
kq(k, 2) = arr(i, 13)
Next j
dic.Add arr(i, 2), k
Else
ODdic = dic.Item(OD)
SL = kq(ODdic, 2)
kq(ODdic, 2) = kq(ODdic, 2) + arr(i, 13)
'===========================================
For Each key In dic.keys
Debug.Print key, dic(key)
For i2 = 1 To UBound(arrD, 1)
m = i2
If OD = arrD(i2, 2) Then
If kq(ODdic, 2) > arrD(i2, 8) Then
kq2(i2, 1) = "Thua " & kq(ODdic, 2) - arrD(i2, 8)
ElseIf kq(ODdic, 2) < arrD(i2, 8) Then
kq2(i2, 1) = "Thieu " & arrD(i2, 8) - kq(ODdic, 2)
ElseIf kq(ODdic, 2) = arrD(i2, 8) Then
kq2(i2, 1) = "Da dong du hang"
End If
End If
Next i2
Next key
End If
End If
Next i
'===========================================

Sheet8.Range("S3").Resize(k, 2) = kq
Sheet8.Range("L3").Resize(m, 1) = kq2
End With
Set dic = Nothing
End Sub
 

File đính kèm

nejisanta đã viết:
For j = 1 To UBound(arr, 2)
kq(k, 1) = arr(i, 2)
kq(k, 2) = arr(i, 13)
Next j
dic.Add arr(i, 2), k
Else
ODdic = dic.Item(OD)
SL = kq(ODdic, 2)
kq(ODdic, 2) = kq(ODdic, 2) + arr(i, 13)
Nhấp chuột vào đây để mở rộng...
Mới chỉ xem lướt qua thấy Cái đoạn đoạn này viết thế này không đúng rồi bạn. for For j = 1 To UBound(arr, 2) nhưng khi gán kết quả thì không thấy J đâu cả.còn phần khác thì chưa xem kỹ nữa
 
nejisanta đã viết:
Code mình như thế này
Nhấp chuột vào đây để mở rộng...
Mã: 
Option Explicit

Sub So_Sanh1()
Dim Arr(), KQ()
Dim I As Long, MaO As String
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")

With Sheet1
    Arr = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, 13).Value
    For I = 1 To UBound(Arr)
        If Trim(Arr(I, 11)) = "Packed" Then
                    MaO = Trim(Arr(I, 2))
            If Not Dic.exists(MaO) Then
                Dic.Item(MaO) = Arr(I, 13)
            Else
                If Not Dic.exists(MaO & "#" & "2") Then
                    Dic.Item(MaO & "#" & "2") = Dic.Item(MaO) + Arr(I, 13)
                Else
                    Dic.Item(MaO & "#" & "2") = Dic.Item(MaO & "#" & "2") + Arr(I, 13)
                End If
            End If
        End If
    Next
End With

With Sheet8
    Arr = .Range("A3", .Range("A" & Rows.Count).End(xlUp)).Resize(, 8).Value
    ReDim KQ(1 To UBound(Arr), 1 To 1)
    For I = 1 To UBound(Arr)
        MaO = Trim(Arr(I, 2)) & "#" & "2"
        If Dic.exists(MaO) Then
            If Arr(I, 8) = Dic.Item(MaO) Then KQ(I, 1) = "Da Dong Du Hang"
            If Arr(I, 8) < Dic.Item(MaO) Then KQ(I, 1) = "Thua " & Dic.Item(MaO) - Arr(I, 8)
            If Arr(I, 8) > Dic.Item(MaO) Then KQ(I, 1) = "Thieu " & Arr(I, 8) - Dic.Item(MaO)
        End If
    Next
.Range("L3").Resize(I - 1, 1).ClearContents
.Range("L3").Resize(I - 1, 1) = KQ
Set Dic = Nothing
End With
End Sub
Bạn sửa thành như thế này.Tranh thủ giờ trưa viết vội bạn test có lỗi thì phản hồi
 
befaint đã viết:
Tình trạng khai báo biến này là kiểu sao chép/ làm theo mấy anh chàng vê lốc đây.
Vài ba bữa lại thấy kiểu này.
Nhấp chuột vào đây để mở rộng...
Trước mình cũng khai báo kiểu này, hồi phổ thông học Pascal khai báo vậy nên giờ áp dụng vô VBA, thấy không báo lỗi nên cứ nghĩ là ổn. :p
 
bomberman211 đã viết:
Trước mình cũng khai báo kiểu này, hồi phổ thông học Pascal khai báo vậy nên giờ áp dụng vô VBA, thấy không báo lỗi nên cứ nghĩ là ổn. :p
Nhấp chuột vào đây để mở rộng...
Ai cũng hiểu chỉ một người không hiểu...
Khai báo kiểu đó hầu hết các ngôn ngữ đều hiểu trừ VBA.

Lý do: VBA có mặc định kiểu Variant. Nguyên tắc (mọi nơi) rằng cái gì có mặc định thì đi theo mặc định, không có mặc định thì dùng nguyên tắc "đi với bụt mặc áo cà sa, đi với ma mặc áo giấy", tức là đi theo cái kế nó.

Bài học đúc kết: học mà không tìm hiểu qua luật mặc định là thiếu sót. Học lập trình mà không học cách thức mặc định là cẩu thả.
 
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

LuuAnh980
Tham chiếu trong công thức bị giảm.
Trả lời
2
Đọc
38
huuthang_bd
huuthang_bd
N
Cách đánh số thứ tự không liên tục (đánh số lại từ đầu khi cột bên cạnh có giá trị)
Trả lời
8
Đọc
152
Phuocam
Phuocam
Thanh12Loan
Xin chào các bác. Em bị lỗi khung hiển thị excell Spreadsheet.
Trả lời
0
Đọc
24
Thanh12Loan
Thanh12Loan
GPE-Trợ Lý
[GPE] TALK SHOW HÀM QUERY - BÍ KÍP BIẾN DỮ LIỆU KHỔNG LỒ THÀNH THÔNG TIN HỮU ÍCH TRONG TÍCH TẮC
    • Thích
    • Yêu thích
Trả lời
1
Đọc
1K
GPE-Trợ Lý
GPE-Trợ Lý
hoamattroicoi
Trích xuất file *.xml sang Excel cho hóa đơn điện tử áp dụng nghị định 123/2020
    • Thích
    • Yêu thích
    • Cảm ơn
5 6 7
Trả lời
123
Đọc
30K
kunkoi9390
K
H
file bị lỗi value khi copy qua file mới.
Trả lời
0
Đọc
22
hoanang_bn84
H
vanle33
File không thao tác gì khi mở ra vẫn hỏi lưu lại khi tắt đi.
Trả lời
9
Đọc
128
hoangtuan.net
hoangtuan.net
H
Cách tạo nhắc nhở trong excel và tự động mở file khi có nhắc nhở
Trả lời
18
Đọc
6K
ongke0711
ongke0711
G
Chuyển Data từ hàng và cột về dạng cột
Trả lời
11
Đọc
169
ptm0412
ptm0412
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
    • Yêu thích
Trả lời
16
Đọc
2K
quyenpv
quyenpv
P
Tại sao khi đánh số thì bị mất hai số cuối
Trả lời
4
Đọc
18K
vanle33
vanle33
HeSanbi
  • Đã giải quyết
LocalizeXL v1.71 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3
Trả lời
58
Đọc
9K
HeSanbi
HeSanbi
linhvu2807
Lỗi hàm công thức Querry
Trả lời
0
Đọc
45
linhvu2807
linhvu2807
C
Tìm dữ liệu khác nhau trong 2 file hoặc 2 sheet trong excel
Trả lời
2
Đọc
135
HUONGHCKT
H
D
Paste dữ liệu, bỏ qua các cell ẩn
2
Trả lời
30
Đọc
46K
HUONGHCKT
H
phatnguyen7301
  • Question Question
Tạo âm thanh khi nhấn vào một phím
Trả lời
3
Đọc
149
yaaasoo01
Y
B
Xin hàm đếm số lượng khách hàng theo 1 điều kiện và bỏ dữ liệu trùng.
Trả lời
11
Đọc
472
bipbo2008
B
HeSanbi
  • Question Question
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
2
Đọc
270
HeSanbi
HeSanbi
NguyenthiH
Sao dùng Ctl + H thay thế không đúng.
Trả lời
19
Đọc
267
NguyenthiH
NguyenthiH
N
Lỗi định dạng số Excel 2019 - Nguyên nhân và cách khắc phục
Trả lời
1
Đọc
60
ptm0412
ptm0412
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
Chúc mừng năm mới.
Back
Top Bottom