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 đỡ ạ

Liên hệ QC
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
9
Đượ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

  • 302506.xlsx
    1.2 MB · Đọc: 40
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

  • 302506.xlsm
    1.2 MB · Đọc: 24
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

  • B...xlsm
    3.8 MB · Đọc: 10
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

TranThanhPhong
Hàm IF
    • Thích
Trả lời
5
Đọc
11K
phamchicong
P
L
Tính tổng và đếm ỗ đã chọn
Trả lời
4
Đọc
5
thuytrangbp28
T
hunganh.nguyen
Xin giúp code tách dòng tổng thành những dòng chi tiết với giá trị là 1
Trả lời
4
Đọc
110
hunganh.nguyen
hunganh.nguyen
N
Làm sao để gửi email có gắn kèm tập tin cho nhiều người bằng chức năng Mail Merge?
Trả lời
19
Đọc
45K
BHTALE
B
Bạn Đoàn
Em có fille excel cần sử lý, mong anh chị giúp đỡ ạ, Em cảm ơn!
Trả lời
8
Đọc
237
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom