Tạo file kiểm tra vật liệu theo từng khu vực bằng VBA

Nongtiep

Thành viên mới
Em chào Anh Chị trong diễn đàn
em có một vẫn đề mong anh chị giúp đỡ ạ
* VẤN ĐỀ: Là em có 1 sheet cơ sở dữ liệu "BOM" ở sheet này em có các (code,model ,vị trí )cố định theo từng khu vực, và có thể thêm model mới & vị trí mới
- Em muốn tạo 1 sheet "CHECK" để kiểm tra các code cần thiết đang chạy ở khu vực nào? model nào? và vị trí nào? để dễ tìm kiếm nhất.
- Trong đó khu vực I có 2 ô để nhập model và khu vực II có 4 vị trí nhập model.(có thể trong khu vực I và II này chung 1 model nhưng vị trí lại khác nhau)
ví dụ như sheet "CHECK" em demo ở File ạ
Ý TƯỞNG: Tạo file kiểm tra bằng Vba
* các bước em muốn theo trình tự như sau ạ
B1: Là khi em dán các code vào cột "CODE CẦN"
B2: nhập tên model vào các ô của từng khu vực I, II
B3: Ấn check để ra các vị trí của code chạy ở model đó của từng khu vực.
file đính kèm:
- Mong Anh Chị trong diễn đàn giúp em với ạ
Bạn cần đăng nhập để thấy hình ảnh
 

HungVinh

Thành viên mới
Dùng công thức được ko? không rõ có đúng ý bạn ko? bạn thử xem nhé.

Bạn cần đăng nhập để thấy hình ảnh
 

Nongtiep

Thành viên mới
Dùng công thức được ko? không rõ có đúng ý bạn ko? bạn thử xem nhé.

Bạn cần đăng nhập để thấy hình ảnh
Cảm ơn A/c đã giúp em... CT thì em biết rồi ạ.
Em muốn viết dạng Vba để em học tâp luôn ạ. Vì em mới tập viết Vba nhưng chưa biết file này bắt đầu từ đâu ạ.
Mong anh chị giúp ạ
 

HungVinh

Thành viên mới
bạn thử xem nhé. T đang tập tành nên code hơi cồng kềnh :)


Mã:
Sub check()
    Dim Dic As Object, DK As Variant
    Dim BomLr As Integer, BomLc As Integer, irow As Integer, jcol As Integer
    Dim CheckLr As Integer, CheckLc As Integer, CheckArr()
    Dim BomArr(), i As Integer, j As Integer, TG As Double
    TG = Timer()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    '------------
    With Sheet3  ' sheet BOM
        BomLr = .Range("B" & Rows.Count).End(xlUp).Row
        BomLc = .Cells(3, Columns.Count).End(xlToLeft).Column
        BomArr = .Range("B3").Resize(BomLr - 2, BomLc - 1)
    End With
    With Sheet4   ' sheet CHECK
        CheckLr = .Range("B" & Rows.Count).End(xlUp).Row
        CheckLc = .Cells(6, Columns.Count).End(xlToLeft).Column
        CheckArr = .Range("B6").Resize(CheckLr - 5, CheckLc - 1)
    End With
    Set Dic = CreateObject("Scripting.dictionary")
    For i = 2 To UBound(CheckArr, 1)
        If CheckArr(i, 1) <> "" Then
            For j = 2 To UBound(CheckArr, 2)
                If CheckArr(1, j) <> "" Then
                    If j < 5 Then ' Khu vuc 1
                        DK = CheckArr(i, 1) & CheckArr(1, j) & 1
                        Dic.Add DK, i & "_" & j
                    Else ' Khu vuc 2
                        DK = CheckArr(i, 1) & CheckArr(1, j) & 2
                        Dic.Add DK, i & "_" & j
                    End If
                End If
            Next j
        End If
    Next i
    '----------------------------------------
    For i = 2 To UBound(BomArr, 1)
        For j = 2 To UBound(BomArr, 2)
            If j < 27 Then ' Khu vuc 1
                DK = BomArr(i, 1) & BomArr(1, j) & 1
                If Dic.exists(DK) Then
                    a = Dic.Item(DK)
                    b = Split(a, "_")
                    irow = CStr(b(0))
                    jcol = CStr(b(1))
                    CheckArr(irow, jcol) = BomArr(i, j)
                End If
            Else ' Khu vuc 2
                DK = BomArr(i, 1) & BomArr(1, j) & 2
                If Dic.exists(DK) Then
                    a = Dic.Item(DK)
                    b = Split(a, "_")
                    irow = CStr(b(0))
                    jcol = CStr(b(1))
                    CheckArr(irow, jcol) = BomArr(i, j)
                End If
            End If
        Next j
    Next i
    Sheet4.Range("B6").Resize(CheckLr - 5, CheckLc - 1) = CheckArr
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "Done " & Round(Timer() - TG, 2)
End Sub
 

Nongtiep

Thành viên mới
bạn thử xem nhé. T đang tập tành nên code hơi cồng kềnh :)


Mã:
Sub check()
    Dim Dic As Object, DK As Variant
    Dim BomLr As Integer, BomLc As Integer, irow As Integer, jcol As Integer
    Dim CheckLr As Integer, CheckLc As Integer, CheckArr()
    Dim BomArr(), i As Integer, j As Integer, TG As Double
    TG = Timer()
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    '------------
    With Sheet3  ' sheet BOM
        BomLr = .Range("B" & Rows.Count).End(xlUp).Row
        BomLc = .Cells(3, Columns.Count).End(xlToLeft).Column
        BomArr = .Range("B3").Resize(BomLr - 2, BomLc - 1)
    End With
    With Sheet4   ' sheet CHECK
        CheckLr = .Range("B" & Rows.Count).End(xlUp).Row
        CheckLc = .Cells(6, Columns.Count).End(xlToLeft).Column
        CheckArr = .Range("B6").Resize(CheckLr - 5, CheckLc - 1)
    End With
    Set Dic = CreateObject("Scripting.dictionary")
    For i = 2 To UBound(CheckArr, 1)
        If CheckArr(i, 1) <> "" Then
            For j = 2 To UBound(CheckArr, 2)
                If CheckArr(1, j) <> "" Then
                    If j < 5 Then ' Khu vuc 1
                        DK = CheckArr(i, 1) & CheckArr(1, j) & 1
                        Dic.Add DK, i & "_" & j
                    Else ' Khu vuc 2
                        DK = CheckArr(i, 1) & CheckArr(1, j) & 2
                        Dic.Add DK, i & "_" & j
                    End If
                End If
            Next j
        End If
    Next i
    '----------------------------------------
    For i = 2 To UBound(BomArr, 1)
        For j = 2 To UBound(BomArr, 2)
            If j < 27 Then ' Khu vuc 1
                DK = BomArr(i, 1) & BomArr(1, j) & 1
                If Dic.exists(DK) Then
                    a = Dic.Item(DK)
                    b = Split(a, "_")
                    irow = CStr(b(0))
                    jcol = CStr(b(1))
                    CheckArr(irow, jcol) = BomArr(i, j)
                End If
            Else ' Khu vuc 2
                DK = BomArr(i, 1) & BomArr(1, j) & 2
                If Dic.exists(DK) Then
                    a = Dic.Item(DK)
                    b = Split(a, "_")
                    irow = CStr(b(0))
                    jcol = CStr(b(1))
                    CheckArr(irow, jcol) = BomArr(i, j)
                End If
            End If
        Next j
    Next i
    Sheet4.Range("B6").Resize(CheckLr - 5, CheckLc - 1) = CheckArr
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "Done " & Round(Timer() - TG, 2)
End Sub
Trước tiên mình cảm ơn bạn đã bớt thời gian cho file của mình. Và xin lỗi vì giờ mới có thời để tl bạn.
Một lần nữa rất rất cảm ơn Bạn đã viết code giúp mình.
 
Top