Em muốn làm bảng phân tích nhanh hơn từ BOM bên khách hàng cho, Mong anh chị giúp đỡ ạ (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ó
Bạn Đoàn

Bạn Đoàn

Thành viên mới
Tham gia
17/6/24
Bài viết
11
Được thích
0
Em muốn làm bảng phân tích nhanh hơn từ BOM bên khách hàng cho, Bình thường em làm thủ công rất là lâu, Mong anh chị giúp đỡ ạ
 

File đính kèm

Nếu bỏ Merge cell thì đa phần có thể dùng hàm vlookup.
 
Bạn Đoàn đã viết:
Em muốn làm bảng phân tích nhanh hơn từ BOM bên khách hàng cho, Bình thường em làm thủ công rất là lâu, Mong anh chị giúp đỡ ạ
Nhấp chuột vào đây để mở rộng...
Làm theo ý hiểu.
Trong khi chờ các giải pháp khác, bạn chủ thớt có thể tham khảo code sau:
Mã: 
Option Explicit

Sub Doan()
Dim i&, j&, Lr&, t&, k&, R&, C&, A&
Dim Arr(), DaTa(), KQ()
Dim Sh As Worksheet, Ws As Worksheet
Dim Dic As Object, Key, Temp
Set Sh = Sheets("DuLieu")
Lr = Sh.Range("A100000").End(xlUp).Row
DaTa = Sh.Range("A2:J" & Lr).Value
R = UBound(DaTa)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = VBA.Trim(DaTa(i, 2))
    Dic(Key) = i
Next i
Set Ws = Sheets("BOM KH")
Lr = Ws.Range("A100000").End(xlUp).Row
Arr = Ws.Range("A7:K" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To R * 10, 1 To 15)
For i = 1 To R
    k = k + 1: A = 0
    Temp = VBA.Trim(Arr(i, 1))
    For j = 1 To Arr(i, 6)
        If j > 1 Then k = k + 1: A = 1
            KQ(k, 1) = k
            KQ(k, 2) = Arr(i, 1)
            KQ(k, 3) = Arr(i, 2)
            If A = 0 Then
                KQ(k, 4) = Arr(i, 6)
                KQ(k, 5) = Split(Arr(i, 2), ">")(0)
                KQ(k, 6) = "SMT"
            End If
            If Dic.Exists(Temp) Then
                KQ(k, 7) = DaTa(Dic(Temp), 4)
                KQ(k, 8) = DaTa(Dic(Temp), 8)
                KQ(k, 9) = DaTa(Dic(Temp), 5)
                KQ(k, 10) = DaTa(Dic(Temp), 7)
                KQ(k, 11) = DaTa(Dic(Temp), 9)
                KQ(k, 12) = DaTa(Dic(Temp), 8)
                KQ(k, 13) = DaTa(Dic(Temp), 10)
                KQ(k, 14) = DaTa(Dic(Temp), 8)
            End If
            If Arr(i, 11) <> Empty Then KQ(k, 15) = Split(Arr(i, 11), ",")(j - 1)
    Next j
Next i
Sheets("BangPhanTic").Range("X13").Resize(k, 15) = KQ
Set Dic = Nothing
End Sub
Kết quả trả về đang để ở Vùng X13:AL...để dex đối chiếu.
Xem file. Nhấn nút mũi tên để xem và kiểm tra kết quả.
 

File đính kèm

HUONGHCKT đã viết:
Làm theo ý hiểu.
Trong khi chờ các giải pháp khác, bạn chủ thớt có thể tham khảo code sau:
Mã: 
Option Explicit

Sub Doan()
Dim i&, j&, Lr&, t&, k&, R&, C&, A&
Dim Arr(), DaTa(), KQ()
Dim Sh As Worksheet, Ws As Worksheet
Dim Dic As Object, Key, Temp
Set Sh = Sheets("DuLieu")
Lr = Sh.Range("A100000").End(xlUp).Row
DaTa = Sh.Range("A2:J" & Lr).Value
R = UBound(DaTa)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = VBA.Trim(DaTa(i, 2))
    Dic(Key) = i
Next i
Set Ws = Sheets("BOM KH")
Lr = Ws.Range("A100000").End(xlUp).Row
Arr = Ws.Range("A7:K" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To R * 10, 1 To 15)
For i = 1 To R
    k = k + 1: A = 0
    Temp = VBA.Trim(Arr(i, 1))
    For j = 1 To Arr(i, 6)
        If j > 1 Then k = k + 1: A = 1
            KQ(k, 1) = k
            KQ(k, 2) = Arr(i, 1)
            KQ(k, 3) = Arr(i, 2)
            If A = 0 Then
                KQ(k, 4) = Arr(i, 6)
                KQ(k, 5) = Split(Arr(i, 2), ">")(0)
                KQ(k, 6) = "SMT"
            End If
            If Dic.Exists(Temp) Then
                KQ(k, 7) = DaTa(Dic(Temp), 4)
                KQ(k, 8) = DaTa(Dic(Temp), 8)
                KQ(k, 9) = DaTa(Dic(Temp), 5)
                KQ(k, 10) = DaTa(Dic(Temp), 7)
                KQ(k, 11) = DaTa(Dic(Temp), 9)
                KQ(k, 12) = DaTa(Dic(Temp), 8)
                KQ(k, 13) = DaTa(Dic(Temp), 10)
                KQ(k, 14) = DaTa(Dic(Temp), 8)
            End If
            If Arr(i, 11) <> Empty Then KQ(k, 15) = Split(Arr(i, 11), ",")(j - 1)
    Next j
Next i
Sheets("BangPhanTic").Range("X13").Resize(k, 15) = KQ
Set Dic = Nothing
End Sub
Kết quả trả về đang để ở Vùng X13:AL...để dex đối chiếu.
Xem file. Nhấn nút mũi tên để xem và kiểm tra kết quả.
Nhấp chuột vào đây để mở rộng...
Vâng, để em xem có được không ạ
 
HUONGHCKT đã viết:
Làm theo ý hiểu.
Trong khi chờ các giải pháp khác, bạn chủ thớt có thể tham khảo code sau:
Mã: 
Option Explicit

Sub Doan()
Dim i&, j&, Lr&, t&, k&, R&, C&, A&
Dim Arr(), DaTa(), KQ()
Dim Sh As Worksheet, Ws As Worksheet
Dim Dic As Object, Key, Temp
Set Sh = Sheets("DuLieu")
Lr = Sh.Range("A100000").End(xlUp).Row
DaTa = Sh.Range("A2:J" & Lr).Value
R = UBound(DaTa)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = VBA.Trim(DaTa(i, 2))
    Dic(Key) = i
Next i
Set Ws = Sheets("BOM KH")
Lr = Ws.Range("A100000").End(xlUp).Row
Arr = Ws.Range("A7:K" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To R * 10, 1 To 15)
For i = 1 To R
    k = k + 1: A = 0
    Temp = VBA.Trim(Arr(i, 1))
    For j = 1 To Arr(i, 6)
        If j > 1 Then k = k + 1: A = 1
            KQ(k, 1) = k
            KQ(k, 2) = Arr(i, 1)
            KQ(k, 3) = Arr(i, 2)
            If A = 0 Then
                KQ(k, 4) = Arr(i, 6)
                KQ(k, 5) = Split(Arr(i, 2), ">")(0)
                KQ(k, 6) = "SMT"
            End If
            If Dic.Exists(Temp) Then
                KQ(k, 7) = DaTa(Dic(Temp), 4)
                KQ(k, 8) = DaTa(Dic(Temp), 8)
                KQ(k, 9) = DaTa(Dic(Temp), 5)
                KQ(k, 10) = DaTa(Dic(Temp), 7)
                KQ(k, 11) = DaTa(Dic(Temp), 9)
                KQ(k, 12) = DaTa(Dic(Temp), 8)
                KQ(k, 13) = DaTa(Dic(Temp), 10)
                KQ(k, 14) = DaTa(Dic(Temp), 8)
            End If
            If Arr(i, 11) <> Empty Then KQ(k, 15) = Split(Arr(i, 11), ",")(j - 1)
    Next j
Next i
Sheets("BangPhanTic").Range("X13").Resize(k, 15) = KQ
Set Dic = Nothing
End Sub
Kết quả trả về đang để ở Vùng X13:AL...để dex đối chiếu.
Xem file. Nhấn nút mũi tên để xem và kiểm tra kết quả.
Nhấp chuột vào đây để mở rộng...
Bác thêm chỗ " Công Đoạn" đang không hoạt động ạ, em cảm ơn
Bài đã được tự động gộp:

 

File đính kèm

Lần chỉnh sửa cuối:
Bạn Đoàn đã viết:
Bác thêm chỗ " Công Đoạn" đang không hoạt động ạ
Nhấp chuột vào đây để mở rộng...
Không hiểu?
Bạn đã chạy thử chưa? Code hoạt động thế nào?
Những chỗ bạn muốn nó là "lặp tay", hay "gì gì đó" mà không nó điều kiện như thế nào thì là "lắp tay" hay như thế nào thì là "SMT" thì chỉ có thánh mới hiểu và làm được.
 
HUONGHCKT đã viết:
Không hiểu?
Bạn đã chạy thử chưa? Code hoạt động thế nào?
Những chỗ bạn muốn nó là "lặp tay", hay "gì gì đó" mà không nó điều kiện như thế nào thì là "lắp tay" hay như thế nào thì là "SMT" thì chỉ có thánh mới hiểu và làm được.
Nhấp chuột vào đây để mở rộng...
Chỗ sheet dữ liệu em có list những mã vật liệu linh kiện gắn tay ạ.
Bài đã được tự động gộp:

Bạn Đoàn đã viết:
Chỗ sheet dữ liệu em có list những mã vật liệu linh kiện gắn tay ạ.
Nhấp chuột vào đây để mở rộng...
Bạn Đoàn đã viết:
còn mã nào không nằm trong list sẽ là mã vật liệu gắn SMT ạ.
Nhấp chuột vào đây để mở rộng...
 
Lần chỉnh sửa cuối:
Bạn Đoàn đã viết:
terwtewtert

đây ạ, bạn check giúp mk vớiView attachment 301856​
Nhấp chuột vào đây để mở rộng...
Thay code cũ bằng code này
Mã: 
Option Explicit
Sub Doan()
Dim i&, j&, Lr&, t&, k&, R&, C&, A&
Dim Arr(), DaTa(), CongDoan(), KQ(), S
Dim Sh As Worksheet, Ws As Worksheet
Dim Dic As Object, Key, Temp
Set Sh = Sheets("DuLieu")
Lr = Sh.Range("A100000").End(xlUp).Row
DaTa = Sh.Range("A3:J" & Lr).Value
CongDoan = Sh.Range("N2:P" & Sh.Range("P100000").End(xlUp).Row).Value
R = UBound(DaTa)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = VBA.Trim(DaTa(i, 2))
    Dic(Key) = i
Next i

For i = 1 To UBound(CongDoan)
    Key = VBA.Trim(CongDoan(i, 1))
    If Not Dic.Exists(Key) Then
        Dic(Key) = i & "," & CongDoan(i, 3)
    Else
        Dic(Key) = Dic(Key) & "," & CongDoan(i, 3)
    End If
Next i

Set Ws = Sheets("BOM KH")
Lr = Ws.Range("A100000").End(xlUp).Row
Arr = Ws.Range("A7:K" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To R * 10, 1 To 15)
For i = 1 To R
    k = k + 1: A = 0
    Temp = VBA.Trim(Arr(i, 1))
    For j = 1 To Arr(i, 6)
        If j > 1 Then k = k + 1: A = 1
            KQ(k, 1) = k
            KQ(k, 2) = Arr(i, 1)
            KQ(k, 3) = Arr(i, 2)
            If A = 0 Then
                KQ(k, 4) = Arr(i, 6)
                KQ(k, 5) = Split(Arr(i, 2), ">")(0)
            End If
            If Dic.Exists(Temp) Then
                S = Split(Dic(Temp), ",")
                If UBound(S) > 0 Then
                    KQ(k, 6) = S(1)
                Else
                    KQ(k, 6) = "SMT"
                End If
                KQ(k, 7) = DaTa(S(0), 4)
                KQ(k, 8) = DaTa(S(0), 8)
                KQ(k, 9) = DaTa(S(0), 5)
                KQ(k, 10) = DaTa(S(0), 7)
                KQ(k, 11) = DaTa(S(0), 9)
                KQ(k, 12) = DaTa(S(0), 8)
                KQ(k, 13) = DaTa(S(0), 10)
                KQ(k, 14) = DaTa(S(0), 8)
            Else
                KQ(k, 6) = "SMT"
            End If
            If Arr(i, 11) <> Empty Then KQ(k, 15) = Split(Arr(i, 11), ",")(j - 1)
    Next j
Next i
Sheets("BangPhanTic").Range("X13").Resize(k, 15) = KQ
Set Dic = Nothing
End Sub
Chạy thử ->>Hồi âm
 
HUONGHCKT đã viết:
Thay code cũ bằng code này
Mã: 
Option Explicit
Sub Doan()
Dim i&, j&, Lr&, t&, k&, R&, C&, A&
Dim Arr(), DaTa(), CongDoan(), KQ(), S
Dim Sh As Worksheet, Ws As Worksheet
Dim Dic As Object, Key, Temp
Set Sh = Sheets("DuLieu")
Lr = Sh.Range("A100000").End(xlUp).Row
DaTa = Sh.Range("A3:J" & Lr).Value
CongDoan = Sh.Range("N2:P" & Sh.Range("P100000").End(xlUp).Row).Value
R = UBound(DaTa)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To R
    Key = VBA.Trim(DaTa(i, 2))
    Dic(Key) = i
Next i

For i = 1 To UBound(CongDoan)
    Key = VBA.Trim(CongDoan(i, 1))
    If Not Dic.Exists(Key) Then
        Dic(Key) = i & "," & CongDoan(i, 3)
    Else
        Dic(Key) = Dic(Key) & "," & CongDoan(i, 3)
    End If
Next i

Set Ws = Sheets("BOM KH")
Lr = Ws.Range("A100000").End(xlUp).Row
Arr = Ws.Range("A7:K" & Lr).Value
R = UBound(Arr)
ReDim KQ(1 To R * 10, 1 To 15)
For i = 1 To R
    k = k + 1: A = 0
    Temp = VBA.Trim(Arr(i, 1))
    For j = 1 To Arr(i, 6)
        If j > 1 Then k = k + 1: A = 1
            KQ(k, 1) = k
            KQ(k, 2) = Arr(i, 1)
            KQ(k, 3) = Arr(i, 2)
            If A = 0 Then
                KQ(k, 4) = Arr(i, 6)
                KQ(k, 5) = Split(Arr(i, 2), ">")(0)
            End If
            If Dic.Exists(Temp) Then
                S = Split(Dic(Temp), ",")
                If UBound(S) > 0 Then
                    KQ(k, 6) = S(1)
                Else
                    KQ(k, 6) = "SMT"
                End If
                KQ(k, 7) = DaTa(S(0), 4)
                KQ(k, 8) = DaTa(S(0), 8)
                KQ(k, 9) = DaTa(S(0), 5)
                KQ(k, 10) = DaTa(S(0), 7)
                KQ(k, 11) = DaTa(S(0), 9)
                KQ(k, 12) = DaTa(S(0), 8)
                KQ(k, 13) = DaTa(S(0), 10)
                KQ(k, 14) = DaTa(S(0), 8)
            Else
                KQ(k, 6) = "SMT"
            End If
            If Arr(i, 11) <> Empty Then KQ(k, 15) = Split(Arr(i, 11), ",")(j - 1)
    Next j
Next i
Sheets("BangPhanTic").Range("X13").Resize(k, 15) = KQ
Set Dic = Nothing
End Sub
Chạy thử ->>Hồi âm
Nhấp chuột vào đây để mở rộng...
Tuyệt vời ông mặt trời luôn ạ. Em cảm ơn
 
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
598
tranduc36
T
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện. (2 người xem)
Trả lời
13
Đọc
105
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 ô (1 người xem)
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
    • 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
Trả lời
2
Đọc
76
DeTong
D
H
Đổi số thành chữ trong office 365 (1 người xem)
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 (1 người xem)
    • 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. (1 người xem)
    • 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