Trích lọc dữ liệu theo nhiều điều kiện (1 người xem)

[huonglien1901]

Chào mọi người!

Em có vấn đề nhờ mọi người hỗ trợ.

1 .Em muốn gõ mã nhà cung cấp(Supplier code) ở cột C3 thì sẽ trích lọc dữ liệu như trong sheet LOC(em có làm ví dụ)
Dữ liệu từ dòng D1:K3 được lấy ở sheet MOQ,sheet LGH, sheet GIO COLLECT, sheet LDH ở file TIMKIEM1.
Dữ liệu ở cột A,B được lấy ở sheet CAR $ PROPOSAL.
2 Khi em gõ vào cột C2 thì sẽ lấy dữ liệu đó ra( như yêu cầu 1)
- Tại vì một nhà cung cấp có nhiều số PO đơn hàng(Order no_1923030791395 số này được gọi số PO đơn hàng).
trong file em làm:
Nhà cung cấp ANH HONG có 2 số PO đơn hàng:

1922030737659 1922030737662

2 số này hiện ra ở ô A3 giống như kiểu tạo Validation.
Em sẽ chọn 01 số thì dữ liệu sẽ thay đổi theo số PO đơn hàng này.
- Dữ liệu khi trích lọc ra tự động căn chỉnh dòng và cột.

Không biết em diễn đạt vậy mọi người có hiểu chưa?

Nhờ mọi người hỗ trợ.

Em cảm ơn mọi người nhiều!

 

[HieuCD]

Chào mọi người!

Em có vấn đề nhờ mọi người hỗ trợ.

1 .Em muốn gõ mã nhà cung cấp(Supplier code) ở cột C3 thì sẽ trích lọc dữ liệu như trong sheet LOC(em có làm ví dụ)
Dữ liệu từ dòng D1:K3 được lấy ở sheet MOQ,sheet LGH, sheet GIO COLLECT, sheet LDH ở file TIMKIEM1.
Dữ liệu ở cột A,B được lấy ở sheet CAR $ PROPOSAL.
2 Khi em gõ vào cột C2 thì sẽ lấy dữ liệu đó ra( như yêu cầu 1)
- Tại vì một nhà cung cấp có nhiều số PO đơn hàng(Order no_1923030791395 số này được gọi số PO đơn hàng).
trong file em làm:
Nhà cung cấp ANH HONG có 2 số PO đơn hàng:

1922030737659 1922030737662

2 số này hiện ra ở ô A3 giống như kiểu tạo Validation.
Em sẽ chọn 01 số thì dữ liệu sẽ thay đổi theo số PO đơn hàng này.
- Dữ liệu khi trích lọc ra tự động căn chỉnh dòng và cột.

Không biết em diễn đạt vậy mọi người có hiểu chưa?

Nhờ mọi người hỗ trợ.

Em cảm ơn mọi người nhiều!

Trong file không có sheet "CAR 14.04"
Nhìn dữ liệu không biết lấy từ cột nào
Gởi lại file với ghi chú thật cụ thể từng cột lấy dữ liệu từ cột nào
Kết quả chỉ liệt kê hay tính tổng? ghi rỏ từng cột
Cho ví dụ 1 dòng

 

[huonglien1901]

Trong file không có sheet "CAR 14.04"
Nhìn dữ liệu không biết lấy từ cột nào
Gởi lại file với ghi chú thật cụ thể từng cột lấy dữ liệu từ cột nào
Kết quả chỉ liệt kê hay tính tổng? ghi rỏ từng cột
Cho ví dụ 1 dòng

Trong file em có làm ví dụ và ghi chú ở sheet LOC.
- Trong file có sheet CAR 14.4 được thay thành sheet( CAR ORDER).
- Kết quả này chỉ liệt kê ra thôi Anh , không tính tổng.

Anh còn vấn đề nào chưa rõ, Anh hỏi em trả lời cho Anh.

Em cảm ơn Anh rất nhiều!

 

[HieuCD]

Trong file em có làm ví dụ và ghi chú ở sheet LOC.
- Trong file có sheet CAR 14.4 được thay thành sheet( CAR ORDER).
- Kết quả này chỉ liệt kê ra thôi Anh , không tính tổng.

Anh còn vấn đề nào chưa rõ, Anh hỏi em trả lời cho Anh.

Em cảm ơn Anh rất nhiều!

Kết quả ở file nào, sheet nào?

 

[huonglien1901]

Kết quả ở file nào, sheet nào?

Kết quả trả về sheet Loc của file car proposal đó Anh.

 

[HieuCD]

Kết quả trả về sheet Loc của file car proposal đó Anh.

Chép code vào sheet loc, lưu file theo đuôi: .xlsm hay .xlsb
2 file phải cùng thư mục

Dim eR As Long

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, Rng As Range
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear

    Call Cot_A_K(Target.Value)
    Set Rng = Range("D3:K3")
    Rng.ClearContents
    Call Dong_3(Rng, Range("C3").Value)

    Application.ScreenUpdating = True
    Application.EnableEvents = True
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Dim sArr(), Res(), oSList As Object
    Dim i As Long, eRow As Long, sRow As Long, k As Long
 
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow <> eR Then
        eR = eRow
        sArr = .Range("C2:C" & eR).Value
        sRow = UBound(sArr)
        Set oSList = CreateObject("System.Collections.SortedList")
        For i = 1 To sRow
          If oSList.ContainsKey(sArr(i, 1)) = False Then oSList.Add sArr(i, 1), ""
        Next
        k = oSList.Count - 1
        ReDim Res(0 To k)
        For i = 0 To k
          Res(i) = oSList.GetKey(i)
        Next i
        Set oSList = Nothing
        Range("A3").Validation.Delete
        Range("A3").Validation.Add 3, , , Join(Res, ",")
      End If
    End With
    Application.EnableEvents = True
  End If
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long
  
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
      
  With wb.Sheets("GIO COLLECT")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
 
  With wb.Sheets("LDH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, q As Long, sRow As Long, k As Long, j As Long
    
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      q = Application.CountIf(.Range("C2:C" & eRow), iKey)
      If q > 0 Then sArr = .Range("C2:AK" & eRow).Value
    End With
    If q > 0 Then
      sRow = UBound(sArr)
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      ReDim Res(1 To q, 1 To UBound(colArr))
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          k = k + 1
          If k = 1 Then
            Range("B3") = sArr(i, 3)
            Range("C3") = sArr(i, 2)
          End If
          For j = 1 To UBound(colArr)
            Res(k, j) = sArr(i, colArr(j))
          Next j
        End If
      Next
      
      Range("A5").Resize(k).NumberFormat = "@"
      Range("A5:K5").Resize(k) = Res
      Range("A5:K5").Resize(k).Borders.LineStyle = 1
    End If
End Sub

 

[huonglien1901]

Chép code vào sheet loc, lưu file theo đuôi: .xlsm hay .xlsb
2 file phải cùng thư mục

Dim eR As Long

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, Rng As Range
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear

    Call Cot_A_K(Target.Value)
    Set Rng = Range("D3:K3")
    Rng.ClearContents
    Call Dong_3(Rng, Range("C3").Value)

    Application.ScreenUpdating = True
    Application.EnableEvents = True
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Dim sArr(), Res(), oSList As Object
    Dim i As Long, eRow As Long, sRow As Long, k As Long

    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow <> eR Then
        eR = eRow
        sArr = .Range("C2:C" & eR).Value
        sRow = UBound(sArr)
        Set oSList = CreateObject("System.Collections.SortedList")
        For i = 1 To sRow
          If oSList.ContainsKey(sArr(i, 1)) = False Then oSList.Add sArr(i, 1), ""
        Next
        k = oSList.Count - 1
        ReDim Res(0 To k)
        For i = 0 To k
          Res(i) = oSList.GetKey(i)
        Next i
        Set oSList = Nothing
        Range("A3").Validation.Delete
        Range("A3").Validation.Add 3, , , Join(Res, ",")
      End If
    End With
    Application.EnableEvents = True
  End If
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long
 
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
     
  With wb.Sheets("GIO COLLECT")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LDH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, q As Long, sRow As Long, k As Long, j As Long
   
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      q = Application.CountIf(.Range("C2:C" & eRow), iKey)
      If q > 0 Then sArr = .Range("C2:AK" & eRow).Value
    End With
    If q > 0 Then
      sRow = UBound(sArr)
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      ReDim Res(1 To q, 1 To UBound(colArr))
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          k = k + 1
          If k = 1 Then
            Range("B3") = sArr(i, 3)
            Range("C3") = sArr(i, 2)
          End If
          For j = 1 To UBound(colArr)
            Res(k, j) = sArr(i, colArr(j))
          Next j
        End If
      Next
     
      Range("A5").Resize(k).NumberFormat = "@"
      Range("A5:K5").Resize(k) = Res
      Range("A5:K5").Resize(k).Borders.LineStyle = 1
    End If
End Sub

khi em mở file lên nó báo lỗi dòng đó.

 

[HeSanbi]

Bạn thử đặt Code dưới vào đầu thủ tục xem sao, phương thức này giúp thêm thư viện cho dự án nếu dự án không có.
Hoặc tạo thủ tục riêng rồi thực thi.
Code dưới tôi hướng dẫn đơn giản, nếu thật đưa vào dự án, chỉnh sửa nghiêm chỉnh hơn, Và code phải đặt ở sự kiện mở workbook

On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\Microsoft.NET\Framework\v4.0.30319\mscorlib.tlb"
'ThisWorkbook.VBProject.References.AddFromguid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 2, 4
On Error Goto 0

 

[huonglien1901]

Bạn thử đặt Code dưới vào đầu thủ tục xem sao, phương thức này giúp thêm thư viện cho dự án nếu dự án không có.
Hoặc tạo thủ tục riêng rồi thực thi.
Code dưới tôi hướng dẫn đơn giản, nếu thật đưa vào dự án, chỉnh sửa nghiêm chỉnh hơn, Và code phải đặt ở sự kiện mở workbook

On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\Microsoft.NET\Framework\v4.0.30319\mscorlib.tlb"
'ThisWorkbook.VBProject.References.AddFromguid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 2, 4
On Error Goto 0

Sao em add vào mà không thấy tác dụng gì Anh.

On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\Microsoft.NET\Framework\v4.0.30319\mscorlib.tlb"
'ThisWorkbook.VBProject.References.AddFromguid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 2, 4
On Error GoTo 0
Dim eR As Long

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, Rng As Range
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear

    Call Cot_A_K(Target.Value)
    Set Rng = Range("D3:K3")
    Rng.ClearContents
    Call Dong_3(Rng, Range("C3").Value)

    Application.ScreenUpdating = True
    Application.EnableEvents = True
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Dim sArr(), Res(), oSList As Object
    Dim i As Long, eRow As Long, sRow As Long, k As Long
 
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow <> eR Then
        eR = eRow
        sArr = .Range("C2:C" & eR).Value
        sRow = UBound(sArr)
        Set oSList = CreateObject("System.Collections.SortedList")
        For i = 1 To sRow
          If oSList.ContainsKey(sArr(i, 1)) = False Then oSList.Add sArr(i, 1), ""
        Next
        k = oSList.Count - 1
        ReDim Res(0 To k)
        For i = 0 To k
          Res(i) = oSList.GetKey(i)
        Next i
        Set oSList = Nothing
        Range("A3").Validation.Delete
        Range("A3").Validation.Add 3, , , Join(Res, ",")
      End If
    End With
    Application.EnableEvents = True
  End If
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long
  
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
      
  With wb.Sheets("GIO COLLECT")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
 
  With wb.Sheets("LDH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, q As Long, sRow As Long, k As Long, j As Long
    
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      q = Application.CountIf(.Range("C2:C" & eRow), iKey)
      If q > 0 Then sArr = .Range("C2:AK" & eRow).Value
    End With
    If q > 0 Then
      sRow = UBound(sArr)
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      ReDim Res(1 To q, 1 To UBound(colArr))
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          k = k + 1
          If k = 1 Then
            Range("B3") = sArr(i, 3)
            Range("C3") = sArr(i, 2)
          End If
          For j = 1 To UBound(colArr)
            Res(k, j) = sArr(i, colArr(j))
          Next j
        End If
      Next
      
      Range("A5").Resize(k).NumberFormat = "@"
      Range("A5:K5").Resize(k) = Res
      Range("A5:K5").Resize(k).Borders.LineStyle = 1
    End If
End Sub

 

[HeSanbi]

Sao em add vào mà không thấy tác dụng gì Anh.

On Error Resume Next
ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\Microsoft.NET\Framework\v4.0.30319\mscorlib.tlb"
'ThisWorkbook.VBProject.References.AddFromguid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 2, 4
On Error GoTo 0
Dim eR As Long

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, Rng As Range
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear

    Call Cot_A_K(Target.Value)
    Set Rng = Range("D3:K3")
    Rng.ClearContents
    Call Dong_3(Rng, Range("C3").Value)

    Application.ScreenUpdating = True
    Application.EnableEvents = True
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Dim sArr(), Res(), oSList As Object
    Dim i As Long, eRow As Long, sRow As Long, k As Long

    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow <> eR Then
        eR = eRow
        sArr = .Range("C2:C" & eR).Value
        sRow = UBound(sArr)
        Set oSList = CreateObject("System.Collections.SortedList")
        For i = 1 To sRow
          If oSList.ContainsKey(sArr(i, 1)) = False Then oSList.Add sArr(i, 1), ""
        Next
        k = oSList.Count - 1
        ReDim Res(0 To k)
        For i = 0 To k
          Res(i) = oSList.GetKey(i)
        Next i
        Set oSList = Nothing
        Range("A3").Validation.Delete
        Range("A3").Validation.Add 3, , , Join(Res, ",")
      End If
    End With
    Application.EnableEvents = True
  End If
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long

  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
  
  With wb.Sheets("GIO COLLECT")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LDH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, q As Long, sRow As Long, k As Long, j As Long

    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      q = Application.CountIf(.Range("C2:C" & eRow), iKey)
      If q > 0 Then sArr = .Range("C2:AK" & eRow).Value
    End With
    If q > 0 Then
      sRow = UBound(sArr)
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      ReDim Res(1 To q, 1 To UBound(colArr))
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          k = k + 1
          If k = 1 Then
            Range("B3") = sArr(i, 3)
            Range("C3") = sArr(i, 2)
          End If
          For j = 1 To UBound(colArr)
            Res(k, j) = sArr(i, colArr(j))
          Next j
        End If
      Next
  
      Range("A5").Resize(k).NumberFormat = "@"
      Range("A5:K5").Resize(k) = Res
      Range("A5:K5").Resize(k).Borders.LineStyle = 1
    End If
End Sub

Bạn vui tính đấy, đầu thủ tục chứ có phải đầu Module / Document hay Class đâu
Chắc do bạn không hiểu "thủ tục" -> Sub và Function hay các Prototype nó gọi chung là thủ tục

 

[huonglien1901]

Chép code vào sheet loc, lưu file theo đuôi: .xlsm hay .xlsb
2 file phải cùng thư mục

Dim eR As Long

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, Rng As Range
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear

    Call Cot_A_K(Target.Value)
    Set Rng = Range("D3:K3")
    Rng.ClearContents
    Call Dong_3(Rng, Range("C3").Value)

    Application.ScreenUpdating = True
    Application.EnableEvents = True
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Dim sArr(), Res(), oSList As Object
    Dim i As Long, eRow As Long, sRow As Long, k As Long

    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow <> eR Then
        eR = eRow
        sArr = .Range("C2:C" & eR).Value
        sRow = UBound(sArr)
        Set oSList = CreateObject("System.Collections.SortedList")
        For i = 1 To sRow
          If oSList.ContainsKey(sArr(i, 1)) = False Then oSList.Add sArr(i, 1), ""
        Next
        k = oSList.Count - 1
        ReDim Res(0 To k)
        For i = 0 To k
          Res(i) = oSList.GetKey(i)
        Next i
        Set oSList = Nothing
        Range("A3").Validation.Delete
        Range("A3").Validation.Add 3, , , Join(Res, ",")
      End If
    End With
    Application.EnableEvents = True
  End If
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long
 
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
     
  With wb.Sheets("GIO COLLECT")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LDH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, q As Long, sRow As Long, k As Long, j As Long
   
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      q = Application.CountIf(.Range("C2:C" & eRow), iKey)
      If q > 0 Then sArr = .Range("C2:AK" & eRow).Value
    End With
    If q > 0 Then
      sRow = UBound(sArr)
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      ReDim Res(1 To q, 1 To UBound(colArr))
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          k = k + 1
          If k = 1 Then
            Range("B3") = sArr(i, 3)
            Range("C3") = sArr(i, 2)
          End If
          For j = 1 To UBound(colArr)
            Res(k, j) = sArr(i, colArr(j))
          Next j
        End If
      Next
     
      Range("A5").Resize(k).NumberFormat = "@"
      Range("A5:K5").Resize(k) = Res
      Range("A5:K5").Resize(k).Borders.LineStyle = 1
    End If
End Sub

Sao em add vào code không chạy đó Anh, không biết em có làm sai gì không nữa.

 

[HeSanbi]

Lỡ đăng bài rồi, thôi thì tôi giúp bạn cho trót:
Hai dòng code tôi đăng ở trên là thêm hai thư viện là:

1. Microsoft Scripting Runtime: ví dụ: CreateObject / GetObject / ... và để khởi tạo biến ở dạng Early Binding là khai báo sớm.
2. Microsoft Collection Library: Nó hỗ trợ ArrayList , Sorted List

Khi tạo một dự án, ta vào Tools - References để thêm thư viện, tuy nhiên có một có thư viện chưa được Import. Ta phải tự tay Import vào.
Và thay vì dùng tay, ta dùng code. Một dự án phải dùng code, thay vì dùng tay, để khi người khác copy lại sẽ không gặp lỗi.

 

[huonglien1901]

Lỡ đăng bài rồi, thôi thì tôi giúp bạn cho trót:
Hai dòng code tôi đăng ở trên là thêm hai thư viện là:

1. Microsoft Scripting Runtime: ví dụ: CreateObject / GetObject / ... và để khởi tạo biến ở dạng Early Binding là khai báo sớm.
2. Microsoft Collection Library: Nó hỗ trợ ArrayList , Sorted List

Khi tạo một dự án, ta vào Tools - References để thêm thư viện, tuy nhiên có một có thư viện chưa được Import. Ta phải tự tay Import vào.
Và thay vì dùng tay, ta dùng code. Một dự án phải dùng code, thay vì dùng tay, để khi người khác copy lại sẽ không gặp lỗi.

Nói thật code em tìm lấy trên diễn đàn về chế lại phục vụ công việc của mình, em không được học bài bản về vấn đề VBA này. Chỉ là lượm mót rồi chế biến lại thôi.
Nếu vậy nhờ Anh kiểm tra code ở bài trên sao không chạy được à.
Em cảm ơn Anh rất nhiều!

 

[HeSanbi]

Bạn Click vào code của ThisWorkbook, rồi copy vào, và Save là được rồi

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  AddRef
End Sub

Private Sub Workbook_Open()
  AddRef
End Sub

Private Sub AddRef()
  On Error Resume Next
  ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
  ThisWorkbook.VBProject.References.AddFromguid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 2, 4
  On Error GoTo 0
End Sub

 

[huonglien1901]

Yêu cầu của em vấn đề này là:
- khi em copy dữ liệu vào ô C3 ở sheet LOC thì sẽ trích lọc dữ liệu ra.
- khi copy vào(nếu NCC có 2 số PO thì sẽ tạo nút giống như kiểu VALIDATION.(nằm ở ô A3)
-khi em chọn 01 số PO thì dữ liệu sẽ thay đổi theo-
-các dữ liệu khi trích lọc ra tự động căn chỉnh dòng và cột.

Bài đã được tự động gộp: 6/6/19

Chép code vào sheet loc, lưu file theo đuôi: .xlsm hay .xlsb
2 file phải cùng thư mục

Dim eR As Long

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, Rng As Range
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear

    Call Cot_A_K(Target.Value)
    Set Rng = Range("D3:K3")
    Rng.ClearContents
    Call Dong_3(Rng, Range("C3").Value)

    Application.ScreenUpdating = True
    Application.EnableEvents = True
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Dim sArr(), Res(), oSList As Object
    Dim i As Long, eRow As Long, sRow As Long, k As Long

    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow <> eR Then
        eR = eRow
        sArr = .Range("C2:C" & eR).Value
        sRow = UBound(sArr)
        Set oSList = CreateObject("System.Collections.SortedList")
        For i = 1 To sRow
          If oSList.ContainsKey(sArr(i, 1)) = False Then oSList.Add sArr(i, 1), ""
        Next
        k = oSList.Count - 1
        ReDim Res(0 To k)
        For i = 0 To k
          Res(i) = oSList.GetKey(i)
        Next i
        Set oSList = Nothing
        Range("A3").Validation.Delete
        Range("A3").Validation.Add 3, , , Join(Res, ",")
      End If
    End With
    Application.EnableEvents = True
  End If
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long
 
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
     
  With wb.Sheets("GIO COLLECT")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LDH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, q As Long, sRow As Long, k As Long, j As Long
   
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      q = Application.CountIf(.Range("C2:C" & eRow), iKey)
      If q > 0 Then sArr = .Range("C2:AK" & eRow).Value
    End With
    If q > 0 Then
      sRow = UBound(sArr)
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      ReDim Res(1 To q, 1 To UBound(colArr))
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          k = k + 1
          If k = 1 Then
            Range("B3") = sArr(i, 3)
            Range("C3") = sArr(i, 2)
          End If
          For j = 1 To UBound(colArr)
            Res(k, j) = sArr(i, colArr(j))
          Next j
        End If
      Next
     
      Range("A5").Resize(k).NumberFormat = "@"
      Range("A5:K5").Resize(k) = Res
      Range("A5:K5").Resize(k).Borders.LineStyle = 1
    End If
End Sub

Anh xem giúp em dữ liệu từ dòng D3:k3 không chạy code Anh ơi.

Nhờ Anh kiểm tra giúp em.

Bài đã được tự động gộp: 6/6/19

Bạn Click vào code của ThisWorkbook, rồi copy vào, và Save là được rồi

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  AddRef
End Sub

Private Sub Workbook_Open()
  AddRef
End Sub

Private Sub AddRef()
  On Error Resume Next
  ThisWorkbook.VBProject.References.AddFromFile "C:\Windows\system32\scrrun.dll"
  ThisWorkbook.VBProject.References.AddFromguid "{BED7F4EA-1A96-11D2-8F08-00A0C9A6186D}", 2, 4
  On Error GoTo 0
End Sub

Code chạy được rồi Anh, nhưng tại sao dòng D3:K3 lại không chạy,
Anh có thể kiểm tra giúp em được không Anh?
Em cảm ơn Anh nhiều.

 

[HeSanbi]

Để Bác Hiếu sẽ giúp bạn, khi viết code giúp bạn xong không biết bác ấy có giúp bạn kiểm soát code không, ví dụ dự án phình to, thêm cột, thêm điều kiện ... Tôi nghĩ là giúp xong còn lại công việc là của bạn đấy.

Bác ấy đã bỏ công viết code giúp bạn, tuy nhiên cách viết code của bác ấy theo xu hướng trợ giúp chứ không phải viết cho một dự án thực sự, bạn đừng buồn khi tôi nói vậy nhé.

Dự án của bạn, vào trong Option tắt chế độ soát lỗi là số đi, không thì mỗi lần dự án được mở lên là luôn luôn soát lỗi.

 

[huonglien1901]

Chép code vào sheet loc, lưu file theo đuôi: .xlsm hay .xlsb
2 file phải cùng thư mục

Dim eR As Long

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, Rng As Range
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Application.ScreenUpdating = False
   
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear

    Call Cot_A_K(Target.Value)
    Set Rng = Range("D3:K3")
    Rng.ClearContents
    Call Dong_3(Rng, Range("C3").Value)

    Application.ScreenUpdating = True
    Application.EnableEvents = True
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address(0, 0) = "A3" Then
    Application.EnableEvents = False
    Dim sArr(), Res(), oSList As Object
    Dim i As Long, eRow As Long, sRow As Long, k As Long

    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow <> eR Then
        eR = eRow
        sArr = .Range("C2:C" & eR).Value
        sRow = UBound(sArr)
        Set oSList = CreateObject("System.Collections.SortedList")
        For i = 1 To sRow
          If oSList.ContainsKey(sArr(i, 1)) = False Then oSList.Add sArr(i, 1), ""
        Next
        k = oSList.Count - 1
        ReDim Res(0 To k)
        For i = 0 To k
          Res(i) = oSList.GetKey(i)
        Next i
        Set oSList = Nothing
        Range("A3").Validation.Delete
        Range("A3").Validation.Add 3, , , Join(Res, ",")
      End If
    End With
    Application.EnableEvents = True
  End If
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long
 
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
     
  With wb.Sheets("GIO COLLECT")
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LDH")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, q As Long, sRow As Long, k As Long, j As Long
   
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      q = Application.CountIf(.Range("C2:C" & eRow), iKey)
      If q > 0 Then sArr = .Range("C2:AK" & eRow).Value
    End With
    If q > 0 Then
      sRow = UBound(sArr)
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      ReDim Res(1 To q, 1 To UBound(colArr))
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          k = k + 1
          If k = 1 Then
            Range("B3") = sArr(i, 3)
            Range("C3") = sArr(i, 2)
          End If
          For j = 1 To UBound(colArr)
            Res(k, j) = sArr(i, colArr(j))
          Next j
        End If
      Next
     
      Range("A5").Resize(k).NumberFormat = "@"
      Range("A5:K5").Resize(k) = Res
      Range("A5:K5").Resize(k).Borders.LineStyle = 1
    End If
End Sub

Em còn vấn đề này nhờ Anh hỗ trợ , dữ liệu ở ô C3 là dạng số không phải dạng chuỗi đó Anh,
em nhờ Anh khi copy vào dữ liệu chuyển thành Text. giống như cột D ở sheet Car proposal đó Anh.

Em cảm ơn Anh rất nhiều!

Bài đã được tự động gộp: 6/6/19

Để Bác Hiếu sẽ giúp bạn, khi viết code giúp bạn xong không biết bác ấy có giúp bạn kiểm soát code không, ví dụ dự án phình to, thêm cột, thêm điều kiện ... Tôi nghĩ là giúp xong còn lại công việc là của bạn đấy.

Bác ấy đã bỏ công viết code giúp bạn, tuy nhiên cách viết code của bác ấy theo xu hướng trợ giúp chứ không phải viết cho một dự án thực sự, bạn đừng buồn khi tôi nói vậy nhé.

Dự án của bạn, vào trong Option tắt chế độ soát lỗi là số đi, không thì mỗi lần dự án được mở lên là luôn luôn soát lỗi.

Em nhờ Anh một việc được không?
Ý em là ô C3 ở sheet LOC sẽ giống như cột D(supplier code) đó Anh.

Em cảm ơn Anh rất nhiều!

 

[HieuCD]

Sao em add vào code không chạy đó Anh, không biết em có làm sai gì không nữa.

Bạn format tay ô A3 và C3 dạng Text giống như file mình gởi, code sẽ chạy bình thường

 

[huonglien1901]

Bạn format tay ô A3 và C3 dạng Text giống như file mình gởi, code sẽ chạy bình thường

Em cảm ơn Hiếu nhiều!
Chúc Anh một buổi tối thật là an lành và hạnh phúc.

 

[HieuCD]

Sao em add vào code không chạy đó Anh, không biết em có làm sai gì không nữa.

Em cảm ơn Hiếu nhiều!
Chúc Anh một buổi tối thật là an lành và hạnh phúc.

Mình đang viết lại code theo yêu cầu của bạn

 

[huonglien1901]

Mình đang viết lại code theo yêu cầu của bạn

Nhờ Anh viết Code sẽ sort từ A-z theo cột Article code.
Em cảm ơn Anh nhiều!
Chúc Anh một ngày đầy năng lượng và đầy niềm vui.

 

[HieuCD]

Nhờ Anh viết Code sẽ sort từ A-z theo cột Article code.
Em cảm ơn Anh nhiều!
Chúc Anh một ngày đầy năng lượng và đầy niềm vui.

Chỉnh lại toàn bộ các code

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, Rng As Range

  If Target.Address(0, 0) = "C3" Then
    Range("C3").NumberFormat = "@"
    Set Rng = Range("D3:K3")
    Call TangToc(False)
    Rng.ClearContents
    If Len(Target.Value) > 0 Then
      Call Dong_3(Rng, Target.Value)
      Call AddDataValidation_A3(Target.Value)
    End If
  End If

  If Target.Address(0, 0) = "A3" Then
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    Call TangToc(False)
    If eRow > 4 Then Range("A5:K" & eRow).Clear
    Call Cot_A_K(Target.Value)
  End If
  Call TangToc(True)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address(0, 0) = "C3" Then
    Dim sArr(), Res(), oSList As Object
    Dim i As Long, eRow As Long, sRow As Long, k As Long
    
    Application.EnableEvents = False
    Range("C3").NumberFormat = "@"
    With Sheets("CAR proposal")
      If .AutoFilterMode = True Then .AutoFilterMode = False
      eRow = .Range("D" & Rows.Count).End(xlUp).Row
      sArr = .Range("D2:D" & eRow).Value
      sRow = UBound(sArr)
      Set oSList = CreateObject("System.Collections.SortedList")
      For i = 1 To sRow
        If oSList.ContainsKey(sArr(i, 1)) = False Then oSList.Add sArr(i, 1), ""
      Next
      k = oSList.Count - 1
      ReDim Res(0 To k)
      For i = 0 To k
        Res(i) = oSList.GetKey(i)
      Next i
      Set oSList = Nothing
      Range("C3").Validation.Delete
      Range("C3").Validation.Add 3, , , Join(Res, ",")
    End With
    Application.EnableEvents = True
  End If
End Sub

Private Sub AddDataValidation_A3(ByVal dk As String)
  Dim sArr(), Res
  Dim i As Long, eRow As Long, sRow As Long, k As Long

  With Sheets("CAR proposal")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    sArr = .Range("C2", .Range("D" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr)
  End With
 
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If sArr(i, 2) = dk Then
        If .exists(sArr(i, 1)) = False Then .Add sArr(i, 1), ""
      End If
    Next
    Range("A3").Validation.Delete
    Res = .keys
    Range("A3").Validation.Add 3, , , Join(Res, ",")
    Call TangToc(True)
    Range("A3") = Res(0)
    'Call TangToc(False)
  End With
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long
  
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
      
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
 
  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, q As Long, sRow As Long, k As Long, j As Long
    
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      q = Application.CountIf(.Range("C2:C" & eRow), iKey)
      If q > 0 Then sArr = .Range("C2:AK" & eRow).Value
    End With
    If q > 0 Then
      sRow = UBound(sArr)
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      ReDim Res(1 To q, 1 To UBound(colArr))
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          k = k + 1
          If k = 1 Then
            Range("B3") = sArr(i, 3)
            Range("C3") = sArr(i, 2)
          End If
          For j = 1 To UBound(colArr)
            Res(k, j) = sArr(i, colArr(j))
          Next j
        End If
      Next
      
      Range("A5").Resize(k).NumberFormat = "@"
      Range("A5:K5").Resize(k) = Res
      Range("A5:K5").Resize(k).Borders.LineStyle = 1
      If k > 1 Then Range("A5:K5").Resize(k).Sort [A5], 1, Header:=xlNo
    End If
End Sub

Private Sub TangToc(ByVal Bln As Boolean)
  Application.EnableEvents = Bln
  Application.ScreenUpdating = Bln
End Sub

 

[huonglien1901]

Chỉnh lại toàn bộ các code

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, Rng As Range

  If Target.Address(0, 0) = "C3" Then
    Range("C3").NumberFormat = "@"
    Set Rng = Range("D3:K3")
    Call TangToc(False)
    Rng.ClearContents
    If Len(Target.Value) > 0 Then
      Call Dong_3(Rng, Target.Value)
      Call AddDataValidation_A3(Target.Value)
    End If
  End If

  If Target.Address(0, 0) = "A3" Then
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    Call TangToc(False)
    If eRow > 4 Then Range("A5:K" & eRow).Clear
    Call Cot_A_K(Target.Value)
  End If
  Call TangToc(True)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Address(0, 0) = "C3" Then
    Dim sArr(), Res(), oSList As Object
    Dim i As Long, eRow As Long, sRow As Long, k As Long
 
    Application.EnableEvents = False
    Range("C3").NumberFormat = "@"
    With Sheets("CAR proposal")
      If .AutoFilterMode = True Then .AutoFilterMode = False
      eRow = .Range("D" & Rows.Count).End(xlUp).Row
      sArr = .Range("D2:D" & eRow).Value
      sRow = UBound(sArr)
      Set oSList = CreateObject("System.Collections.SortedList")
      For i = 1 To sRow
        If oSList.ContainsKey(sArr(i, 1)) = False Then oSList.Add sArr(i, 1), ""
      Next
      k = oSList.Count - 1
      ReDim Res(0 To k)
      For i = 0 To k
        Res(i) = oSList.GetKey(i)
      Next i
      Set oSList = Nothing
      Range("C3").Validation.Delete
      Range("C3").Validation.Add 3, , , Join(Res, ",")
    End With
    Application.EnableEvents = True
  End If
End Sub

Private Sub AddDataValidation_A3(ByVal dk As String)
  Dim sArr(), Res
  Dim i As Long, eRow As Long, sRow As Long, k As Long

  With Sheets("CAR proposal")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    sArr = .Range("C2", .Range("D" & Rows.Count).End(xlUp)).Value
    sRow = UBound(sArr)
  End With

  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If sArr(i, 2) = dk Then
        If .exists(sArr(i, 1)) = False Then .Add sArr(i, 1), ""
      End If
    Next
    Range("A3").Validation.Delete
    Res = .keys
    Range("A3").Validation.Add 3, , , Join(Res, ",")
    Call TangToc(True)
    Range("A3") = Res(0)
    'Call TangToc(False)
  End With
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long

  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
   
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, q As Long, sRow As Long, k As Long, j As Long
 
    With Sheets("CAR proposal")
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      q = Application.CountIf(.Range("C2:C" & eRow), iKey)
      If q > 0 Then sArr = .Range("C2:AK" & eRow).Value
    End With
    If q > 0 Then
      sRow = UBound(sArr)
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      ReDim Res(1 To q, 1 To UBound(colArr))
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          k = k + 1
          If k = 1 Then
            Range("B3") = sArr(i, 3)
            Range("C3") = sArr(i, 2)
          End If
          For j = 1 To UBound(colArr)
            Res(k, j) = sArr(i, colArr(j))
          Next j
        End If
      Next
   
      Range("A5").Resize(k).NumberFormat = "@"
      Range("A5:K5").Resize(k) = Res
      Range("A5:K5").Resize(k).Borders.LineStyle = 1
      If k > 1 Then Range("A5:K5").Resize(k).Sort [A5], 1, Header:=xlNo
    End If
End Sub

Private Sub TangToc(ByVal Bln As Boolean)
  Application.EnableEvents = Bln
  Application.ScreenUpdating = Bln
End Sub

Em cảm ơn Anh Hiếu nhiều!
Cách của Anh làm rất hay.
Em có vấn đề này nhờ Anh hỗ trợ tiếp.
yêu cầu của em.
những dữ liệu sẽ lấy bên sheet CAR PROPOSAL đó Anh. và file DULIEUTIMKIEM1.
1- ở ô B1, khi em chọn Block, thì ô A3 sẽ hiện ra những hợp đồng nào có chứa đơn block.(giống như kiểu tạo validation đó Anh.)
- Đơn hàng được gọi Block khi cột W(PU quantity) ở sheet CAR PROPASAL có số lượng để trống hoặc =0
- Đơn hàng Awating khi cột W(PU quantity) sheet CAR PROPASAL có số lượng lớn hơn 0.
2. khi em chọn 01 mã hợp đồng của đơn hàng Block thì sẽ trích lọc tất cả các nhà cung cấp có đơn Block.
Ví dụ: giả sử em chọn mã hợp đồng là M, đơn Block. thì sẽ trích lọc tất cả các nhà cung cấp của mã hợp đồng M này có chứa đơn block.(giống như trong sheet LOC em có làm ví dụ minh họa)
3- khi trích lọc dữ liệu ra tự động căn chỉnh dòng và cột.
4- sắp sếp cột ARTICLE CODE từ A-Z theo từng nhà cung cấp.

Nếu được Anh giúp, em cảm ơn Anh rất nhiều!
Chúc Anh một buổi tối an lành!

 

[HieuCD]

Em cảm ơn Anh Hiếu nhiều!
Cách của Anh làm rất hay.
Em có vấn đề này nhờ Anh hỗ trợ tiếp.
yêu cầu của em.
những dữ liệu sẽ lấy bên sheet CAR PROPOSAL đó Anh. và file DULIEUTIMKIEM1.
1- ở ô B1, khi em chọn Block, thì ô A3 sẽ hiện ra những hợp đồng nào có chứa đơn block.(giống như kiểu tạo validation đó Anh.)
- Đơn hàng được gọi Block khi cột W(PU quantity) ở sheet CAR PROPASAL có số lượng để trống hoặc =0
- Đơn hàng Awating khi cột W(PU quantity) sheet CAR PROPASAL có số lượng lớn hơn 0.
2. khi em chọn 01 mã hợp đồng của đơn hàng Block thì sẽ trích lọc tất cả các nhà cung cấp có đơn Block.
Ví dụ: giả sử em chọn mã hợp đồng là M, đơn Block. thì sẽ trích lọc tất cả các nhà cung cấp của mã hợp đồng M này có chứa đơn block.(giống như trong sheet LOC em có làm ví dụ minh họa)
3- khi trích lọc dữ liệu ra tự động căn chỉnh dòng và cột.
4- sắp sếp cột ARTICLE CODE từ A-Z theo từng nhà cung cấp.

Nếu được Anh giúp, em cảm ơn Anh rất nhiều!
Chúc Anh một buổi tối an lành!

File bị gì đó, khi mở lên các data validation biến mất nên không rỏ thao tác và yêu cầu của bạn là gì?
Sheet Loc trùng nhiều kết quả là sao?
". khi em chọn 01 mã hợp đồng của đơn hàng Block thì sẽ trích lọc tất cả các nhà cung cấp có đơn Block.: 1 hợp đồng là của 1 nhà cung cấp, làm sao có nhiều nhà cung cấp được
chọn mã hợp đồng là M: Là như thế nào?

 

[huonglien1901]

File bị gì đó, khi mở lên các data validation biến mất nên không rỏ thao tác và yêu cầu của bạn là gì?
Sheet Loc trùng nhiều kết quả là sao?
". khi em chọn 01 mã hợp đồng của đơn hàng Block thì sẽ trích lọc tất cả các nhà cung cấp có đơn Block.: 1 hợp đồng là của 1 nhà cung cấp, làm sao có nhiều nhà cung cấp được
chọn mã hợp đồng là M: Là như thế nào?

File Anh làm cho em rất hay.
Trong file này em có lấy ví dụ cho Anh dễ hiểu.
Dạ đúng rồi Anh. 01 hợp đồng có 01 nhà cung cấp thôi Anh.
Nhưng em muốn lấy chữ cái đầu thôi Anh à. Giống như M4130127 mã hợp đồng của nhà cung cấp LOTTE. thì em chỉ lấy chữ cái đầu M thôi Anh.
Ở Ô B1 KHI CHỌN STATUS: BLOCK thì ô A3 sẽ hiển thị giống như cách Anh chọn nhà cung cấp(với code #22) đó Anh.
ô A3 chính là mã hợp đồng quầy(M,N,P,Q,O,R,S,T).
trong file em có ghi chú lại.
Em gửi Anh lại file!

 

[HieuCD]

File Anh làm cho em rất hay.
Trong file này em có lấy ví dụ cho Anh dễ hiểu.
Dạ đúng rồi Anh. 01 hợp đồng có 01 nhà cung cấp thôi Anh.
Nhưng em muốn lấy chữ cái đầu thôi Anh à. Giống như M4130127 mã hợp đồng của nhà cung cấp LOTTE. thì em chỉ lấy chữ cái đầu M thôi Anh.
Ở Ô B1 KHI CHỌN STATUS: BLOCK thì ô A3 sẽ hiển thị giống như cách Anh chọn nhà cung cấp(với code #22) đó Anh.
ô A3 chính là mã hợp đồng quầy(M,N,P,Q,O,R,S,T).
trong file em có ghi chú lại.
Em gửi Anh lại file!

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, supBln As Boolean, Rng As Range
 
  If Target.Address(0, 0) = "A3" Or Target.Address(0, 0) = "B1" Then
    Call TangToc(False)
    Call AddValidation_C3(supBln)
    Call TangToc(True)
    If supBln = False Then
      Range("C3") = Empty
    Else
      Call TangToc(False)
      eRow = Range("A" & Rows.Count).End(xlUp).Row
      If eRow > 4 Then Range("A5:K" & eRow).Clear
      Call Cot_A_K(Range("C3").Value)
      Call TangToc(True)
    End If
  End If
 
  If Target.Address(0, 0) = "C3" Then
    Set Rng = Range("D3:K3")
    Call TangToc(False)
    Rng.ClearContents
    Range("B3").ClearContents
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear
    
    If Len(Target.Value) > 0 Then
      Call Dong_3(Rng, Target.Value)
      Call Cot_A_K(Target.Value)
    End If
    Call TangToc(True)
  End If
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, sRow As Long, k As Long, j As Long
    Dim bln As Boolean, Contract As String, Stastus As String
    
    With Sheets("CAR proposal")
      eRow = .Range("D" & Rows.Count).End(xlUp).Row
      sArr = .Range("D2:AK" & eRow).Value
    End With
    
    sRow = UBound(sArr)
    colArr = Array(, 8, 10, 20, 21, 22, 25, 30, 31, 32, 33, 34)
    ReDim Res(1 To sRow, 1 To UBound(colArr))
    
    Stastus = UCase(Range("B1").Value)
    If Stastus = "AWATING" Then bln = True
    Contract = UCase(Range("A3").Value) & "*"
    For i = 1 To sRow
      If sArr(i, 1) = iKey Then
        If ((sArr(i, 20) > 0) = bln) Or Len(Stastus) = 0 Then '***
          If UCase(sArr(i, 3)) Like Contract Then
            k = k + 1
            If k = 1 Then Range("B3") = sArr(i, 2)
            For j = 1 To UBound(colArr)
              Res(k, j) = sArr(i, colArr(j))
            Next j
          End If
        End If
      End If
    Next i
    Range("A5").Resize(k).NumberFormat = "@"
    Range("A5:K5").Resize(k) = Res
    Range("A5:K5").Resize(k).Borders.LineStyle = 1
    If k > 1 Then Range("A5:K5").Resize(k).Sort [A5], 1, Header:=xlNo
End Sub

Private Sub AddValidation_C3(ByRef supBln)
  Dim sArr1(), sArr2(), sArr3(), Res()
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim bln As Boolean, Contract As String, Stastus As String, Supplier As String
  With Sheets("CAR proposal")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    sArr1 = .Range("W2:W" & eRow).Value
    sArr2 = .Range("F2:F" & eRow).Value
    sArr3 = .Range("D2:D" & eRow).Value
  End With
  sRow = UBound(sArr3)
 
  Stastus = UCase(Range("B1").Value)
  If UCase(Stastus) = "AWATING" Then bln = True
  Contract = UCase(Range("A3").Value) & "*"
  Supplier = Range("C3").Value
  With CreateObject("System.Collections.SortedList")
    For i = 1 To sRow
      If ((sArr1(i, 1) > 0) = bln) Or Len(Stastus) = 0 Then
        If UCase(sArr2(i, 1)) Like Contract Then
          If .ContainsKey(sArr3(i, 1)) = False Then
            If Supplier = sArr3(i, 1) Then supBln = True
            .Add sArr3(i, 1), ""
          End If
        End If
      End If
    Next
    k = .Count - 1
    ReDim Res(0 To k)
    For i = 0 To k
      Res(i) = .GetKey(i)
    Next i
  End With
  Range("C3").Validation.Delete
  Range("C3").Validation.Add 3, , , Join(Res, ",")
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long
  
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
      
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
 
  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub TangToc(ByVal bln As Boolean)
  Application.EnableEvents = bln
  Application.ScreenUpdating = bln
End Sub

 

[huonglien1901]

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, supBln As Boolean, Rng As Range

  If Target.Address(0, 0) = "A3" Or Target.Address(0, 0) = "B1" Then
    Call TangToc(False)
    Call AddValidation_C3(supBln)
    Call TangToc(True)
    If supBln = False Then
      Range("C3") = Empty
    Else
      Call TangToc(False)
      eRow = Range("A" & Rows.Count).End(xlUp).Row
      If eRow > 4 Then Range("A5:K" & eRow).Clear
      Call Cot_A_K(Range("C3").Value)
      Call TangToc(True)
    End If
  End If

  If Target.Address(0, 0) = "C3" Then
    Set Rng = Range("D3:K3")
    Call TangToc(False)
    Rng.ClearContents
    Range("B3").ClearContents
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear
  
    If Len(Target.Value) > 0 Then
      Call Dong_3(Rng, Target.Value)
      Call Cot_A_K(Target.Value)
    End If
    Call TangToc(True)
  End If
End Sub

Private Sub Cot_A_K(ByVal iKey As String)
    Dim sArr(), Res(), colArr()
    Dim i As Long, eRow As Long, sRow As Long, k As Long, j As Long
    Dim bln As Boolean, Contract As String, Stastus As String
  
    With Sheets("CAR proposal")
      eRow = .Range("D" & Rows.Count).End(xlUp).Row
      sArr = .Range("D2:AK" & eRow).Value
    End With
  
    sRow = UBound(sArr)
    colArr = Array(, 8, 10, 20, 21, 22, 25, 30, 31, 32, 33, 34)
    ReDim Res(1 To sRow, 1 To UBound(colArr))
  
    Stastus = UCase(Range("B1").Value)
    If Stastus = "AWATING" Then bln = True
    Contract = UCase(Range("A3").Value) & "*"
    For i = 1 To sRow
      If sArr(i, 1) = iKey Then
        If ((sArr(i, 20) > 0) = bln) Or Len(Stastus) = 0 Then '***
          If UCase(sArr(i, 3)) Like Contract Then
            k = k + 1
            If k = 1 Then Range("B3") = sArr(i, 2)
            For j = 1 To UBound(colArr)
              Res(k, j) = sArr(i, colArr(j))
            Next j
          End If
        End If
      End If
    Next i
    Range("A5").Resize(k).NumberFormat = "@"
    Range("A5:K5").Resize(k) = Res
    Range("A5:K5").Resize(k).Borders.LineStyle = 1
    If k > 1 Then Range("A5:K5").Resize(k).Sort [A5], 1, Header:=xlNo
End Sub

Private Sub AddValidation_C3(ByRef supBln)
  Dim sArr1(), sArr2(), sArr3(), Res()
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim bln As Boolean, Contract As String, Stastus As String, Supplier As String
  With Sheets("CAR proposal")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("D" & Rows.Count).End(xlUp).Row
    sArr1 = .Range("W2:W" & eRow).Value
    sArr2 = .Range("F2:F" & eRow).Value
    sArr3 = .Range("D2:D" & eRow).Value
  End With
  sRow = UBound(sArr3)

  Stastus = UCase(Range("B1").Value)
  If UCase(Stastus) = "AWATING" Then bln = True
  Contract = UCase(Range("A3").Value) & "*"
  Supplier = Range("C3").Value
  With CreateObject("System.Collections.SortedList")
    For i = 1 To sRow
      If ((sArr1(i, 1) > 0) = bln) Or Len(Stastus) = 0 Then
        If UCase(sArr2(i, 1)) Like Contract Then
          If .ContainsKey(sArr3(i, 1)) = False Then
            If Supplier = sArr3(i, 1) Then supBln = True
            .Add sArr3(i, 1), ""
          End If
        End If
      End If
    Next
    k = .Count - 1
    ReDim Res(0 To k)
    For i = 0 To k
      Res(i) = .GetKey(i)
    Next i
  End With
  Range("C3").Validation.Delete
  Range("C3").Validation.Add 3, , , Join(Res, ",")
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long

  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:H" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:I" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With
    
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("A2:C" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i
    End If
  End With

  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then
      sArr = .Range("B2:P" & eRow).Value
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
    End If
  End With
  wb.Close False
End Sub

Private Sub TangToc(ByVal bln As Boolean)
  Application.EnableEvents = bln
  Application.ScreenUpdating = bln
End Sub

Em cảm ơn Anh rất nhiều!
Anh ơi có thể nào mà khi em chọn ô B1 Status:Block/Awating thì ô A3 sẽ hiển thị tất cả các mã quầy(mã hợp đồng)chứa đơn hàng có trạng thái đó.
Khi em chọn mã quầy nào đó(Ví dụ mã HD ,R thì sẽ trích lọc ra tất cả các nhà cung cấp có chứa hợp đồng đó và có trạng thái Block/Awating.
Các nhà cung cấp khi trích lọc ra thì sẽ hiển thị các cột(như trong file demo em có gửi Anh)
các nhà cung cấp nối tiếp nhau., chứ không phải giống như mình chọn từng nhà cung cấp vậy.
Em cảm ơn Anh đã hỗ trợ giúp em.
Không biết em nói vậy có làm Anh khó hiểu hơn không?
em gửi hình cho Anh dễ hiểu,
-Trường hợp dữ liệu bên sheet Car Proposal chưa có, thì thông báo chưa có dữ liệu.
Em muốn trích lọc dữ liệu để em in đó Anh.chứ in từng nhà cung cấp của 01 mã HD chắc không xong, nên em muốn nhờ Anh hỗ trợ.

 

[HieuCD]

Em cảm ơn Anh rất nhiều!
Anh ơi có thể nào mà khi em chọn ô B1 Status:Block/Awating thì ô A3 sẽ hiển thị tất cả các mã quầy(mã hợp đồng)chứa đơn hàng có trạng thái đó.
Khi em chọn mã quầy nào đó(Ví dụ mã HD ,R thì sẽ trích lọc ra tất cả các nhà cung cấp có chứa hợp đồng đó và có trạng thái Block/Awating.
Các nhà cung cấp khi trích lọc ra thì sẽ hiển thị các cột(như trong file demo em có gửi Anh)
các nhà cung cấp nối tiếp nhau., chứ không phải giống như mình chọn từng nhà cung cấp vậy.
Em cảm ơn Anh đã hỗ trợ giúp em.
Không biết em nói vậy có làm Anh khó hiểu hơn không?
em gửi hình cho Anh dễ hiểu,
-Trường hợp dữ liệu bên sheet Car Proposal chưa có, thì thông báo chưa có dữ liệu.
Em muốn trích lọc dữ liệu để em in đó Anh.chứ in từng nhà cung cấp của 01 mã HD chắc không xong, nên em muốn nhờ Anh hỗ trợ.View attachment 218784
View attachment 218784

Chỉnh lại code

Dim aMOQ, aLGH, aGIOCOLLECT, aLDH

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, supBln As Boolean, Rng As Range
 
  If Target.Address(0, 0) = "A3" Or Target.Address(0, 0) = "B1" Then
    Call TangToc(False)
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear
    Call LungTung
    Call TangToc(True)
  End If
End Sub

Private Sub LungTung()
  Dim sArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey, Bln As Boolean
 
  With Sheets("CAR proposal")
    sArr = .Range("D2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
 
  Stastus = UCase(Range("B1").Value)
  If UCase(Stastus) = "AWATING" Then Bln = True
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If ((sArr(i, 20) > 0) = Bln) Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 3)) Like Contract Then
          iKey = sArr(i, 1)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
    
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 8, 10, 20, 21, 22, 25, 30, 31, 32, 33, 34)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Call Dong_3(Rng, iKey)
        
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 2)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
        
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

Private Sub CreateArr_DuLieuTimkiem()
  Dim wb As Workbook, eRow As Long
  
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aMOQ = .Range("B2:H" & eRow).Value
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLGH = .Range("B2:I" & eRow).Value
  End With
      
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aGIOCOLLECT = .Range("A2:C" & eRow).Value
  End With
 
  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLDH = .Range("B2:P" & eRow).Value
  End With
  wb.Close False
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long

      sArr = aMOQ
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i

      sArr = aLGH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aGIOCOLLECT
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aLDH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
End Sub

Private Sub TangToc(ByVal Bln As Boolean)
  Application.EnableEvents = Bln
  Application.ScreenUpdating = Bln
End Sub

 

[huonglien1901]

Chỉnh lại code

Dim aMOQ, aLGH, aGIOCOLLECT, aLDH

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, supBln As Boolean, Rng As Range

  If Target.Address(0, 0) = "A3" Or Target.Address(0, 0) = "B1" Then
    Call TangToc(False)
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear
    Call LungTung
    Call TangToc(True)
  End If
End Sub

Private Sub LungTung()
  Dim sArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey, Bln As Boolean

  With Sheets("CAR proposal")
    sArr = .Range("D2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)

  Stastus = UCase(Range("B1").Value)
  If UCase(Stastus) = "AWATING" Then Bln = True
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If ((sArr(i, 20) > 0) = Bln) Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 3)) Like Contract Then
          iKey = sArr(i, 1)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
   
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 8, 10, 20, 21, 22, 25, 30, 31, 32, 33, 34)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Call Dong_3(Rng, iKey)
       
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 2)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
       
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

Private Sub CreateArr_DuLieuTimkiem()
  Dim wb As Workbook, eRow As Long
 
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aMOQ = .Range("B2:H" & eRow).Value
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLGH = .Range("B2:I" & eRow).Value
  End With
     
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aGIOCOLLECT = .Range("A2:C" & eRow).Value
  End With

  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLDH = .Range("B2:P" & eRow).Value
  End With
  wb.Close False
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long

      sArr = aMOQ
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i

      sArr = aLGH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aGIOCOLLECT
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aLDH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
End Sub

Private Sub TangToc(ByVal Bln As Boolean)
  Application.EnableEvents = Bln
  Application.ScreenUpdating = Bln
End Sub

Quá tuyệt vời luôn Anh!
Em cảm ơn Anh Hiếu nhiều! Anh giúp em nhiều mà em chưa có cơ hội báo đáp lại Anh.
Khi nào rãnh em sẽ chạy xuống Bình Dương mời Anh, và mời Anh @Phan Thế Hiệp (Anh Quốc) đi cafe đàm đạo cho vui.
Thành thật em cảm ơn Anh nhiều lắm, em chẳng biết nói gì hơn chằng ngoài hai chữ này.
Em chúc Anh một buổi tối thiệt là ngon giấc.

 

[huonglien1901]

Chỉnh lại code

Dim aMOQ, aLGH, aGIOCOLLECT, aLDH

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, supBln As Boolean, Rng As Range

  If Target.Address(0, 0) = "A3" Or Target.Address(0, 0) = "B1" Then
    Call TangToc(False)
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear
    Call LungTung
    Call TangToc(True)
  End If
End Sub

Private Sub LungTung()
  Dim sArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey, Bln As Boolean

  With Sheets("CAR proposal")
    sArr = .Range("D2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)

  Stastus = UCase(Range("B1").Value)
  If UCase(Stastus) = "AWATING" Then Bln = True
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If ((sArr(i, 20) > 0) = Bln) Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 3)) Like Contract Then
          iKey = sArr(i, 1)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
  
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 8, 10, 20, 21, 22, 25, 30, 31, 32, 33, 34)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Call Dong_3(Rng, iKey)
      
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 2)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
      
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

Private Sub CreateArr_DuLieuTimkiem()
  Dim wb As Workbook, eRow As Long

  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aMOQ = .Range("B2:H" & eRow).Value
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLGH = .Range("B2:I" & eRow).Value
  End With
    
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aGIOCOLLECT = .Range("A2:C" & eRow).Value
  End With

  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLDH = .Range("B2:P" & eRow).Value
  End With
  wb.Close False
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long

      sArr = aMOQ
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i

      sArr = aLGH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aGIOCOLLECT
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aLDH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
End Sub

Private Sub TangToc(ByVal Bln As Boolean)
  Application.EnableEvents = Bln
  Application.ScreenUpdating = Bln
End Sub

Anh Hiếu ơi! em có vấn đề phát sinh:

- Đơn hàng được gọi Block khi cột W(PU quantity) ở sheet CAR PROPASAL có số lượng để trống hoặc =0
- Đơn hàng Awating khi cột W(PU quantity) sheet CAR PROPASAL có số lượng lớn hơn 0.

Đơn hàng BLOCK/AWATING em có nêu ở bài #28 , em đưa ra điều kiện sai, Em xin lỗi Anh nhiều!
- Đơn hàng Block/Awating dựa vào sheet(CAR ORDER) để lấy. kết quả tại cột F(STATUS) của sheet CAR ORDER, dựa vào điều kiện cột Order No của sheet CAR Proposal.
Em có làm ví dụ trong sheet CAR PROPOSAL của cột AP.(Cột AP em có làm ví dụ sử dụng hàm vlookup đó Anh)
- cột Order No bên sheet CAR ORDER đang dạng số không phải dạng text. Em muốn nhờ Anh định dạng cột Cột B(order No) là dạng text.
làm thế nào mình dò kết quả đó mà không sử dụng công thức được không Anh?

Em cảm ơn Anh rất nhiều!

 

[HieuCD]

Anh Hiếu ơi! em có vấn đề phát sinh:

Đơn hàng BLOCK/AWATING em có nêu ở bài #28 , em đưa ra điều kiện sai, Em xin lỗi Anh nhiều!
- Đơn hàng Block/Awating dựa vào sheet(CAR ORDER) để lấy. kết quả tại cột F(STATUS) của sheet CAR ORDER, dựa vào điều kiện cột Order No của sheet CAR Proposal.
Em có làm ví dụ trong sheet CAR PROPOSAL của cột AP.(Cột AP em có làm ví dụ sử dụng hàm vlookup đó Anh)
- cột Order No bên sheet CAR ORDER đang dạng số không phải dạng text. Em muốn nhờ Anh định dạng cột Cột B(order No) là dạng text.
làm thế nào mình dò kết quả đó mà không sử dụng công thức được không Anh?

Em cảm ơn Anh rất nhiều!

Trong file, CAR ORDER là dạng Text, nếu thích thì Format cell thêm bằng tay cho chắc

Dim aMOQ, aLGH, aGIOCOLLECT, aLDH

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, supBln As Boolean, Rng As Range
 
  If Target.Address(0, 0) = "A3" Or Target.Address(0, 0) = "B1" Then
    Call TangToc(False)
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear
    Call LungTung
    Call TangToc(True)
  End If
End Sub

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
 
  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
 
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With
 
  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
    
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Call Dong_3(Rng, iKey)
        
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 2)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
        
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

Private Sub CreateArr_DuLieuTimkiem()
  Dim wb As Workbook, eRow As Long
  
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aMOQ = .Range("B2:H" & eRow).Value
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLGH = .Range("B2:I" & eRow).Value
  End With
      
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aGIOCOLLECT = .Range("A2:C" & eRow).Value
  End With
 
  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLDH = .Range("B2:P" & eRow).Value
  End With
  wb.Close False
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long

      sArr = aMOQ
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i

      sArr = aLGH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aGIOCOLLECT
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aLDH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
End Sub

Private Sub TangToc(ByVal Bln As Boolean)
  Application.EnableEvents = Bln
  Application.ScreenUpdating = Bln
End Sub

 

[huonglien1901]

Trong file, CAR ORDER là dạng Text, nếu thích thì Format cell thêm bằng tay cho chắc

Dim aMOQ, aLGH, aGIOCOLLECT, aLDH

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, supBln As Boolean, Rng As Range

  If Target.Address(0, 0) = "A3" Or Target.Address(0, 0) = "B1" Then
    Call TangToc(False)
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear
    Call LungTung
    Call TangToc(True)
  End If
End Sub

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With

  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)

  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With

  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
   
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Call Dong_3(Rng, iKey)
       
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 2)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
       
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

Private Sub CreateArr_DuLieuTimkiem()
  Dim wb As Workbook, eRow As Long
 
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aMOQ = .Range("B2:H" & eRow).Value
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLGH = .Range("B2:I" & eRow).Value
  End With
     
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aGIOCOLLECT = .Range("A2:C" & eRow).Value
  End With

  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLDH = .Range("B2:P" & eRow).Value
  End With
  wb.Close False
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long

      sArr = aMOQ
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i

      sArr = aLGH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aGIOCOLLECT
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aLDH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
End Sub

Private Sub TangToc(ByVal Bln As Boolean)
  Application.EnableEvents = Bln
  Application.ScreenUpdating = Bln
End Sub

Anh ơi cột này em có khoanh màu nó, nó phải hiển thị tên nhà cung cấp, giờ nó lại hiển thị mã nhà cung cấp.
Nhờ Anh hỗ trợ sửa giúp em với.

 

[HieuCD]

Anh ơi cột này em có khoanh màu nó, nó phải hiển thị tên nhà cung cấp, giờ nó lại hiển thị mã nhà cung cấp.
Nhờ Anh hỗ trợ sửa giúp em với.
View attachment 218849

Chỉnh cột bị sót 1 lệnh
If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
 
  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
 
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With
 
  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
    
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Call Dong_3(Rng, iKey)
        
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
        
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

 

[huonglien1901]

Chỉnh cột bị sót 1 lệnh
If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With

  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)

  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With

  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
  
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Call Dong_3(Rng, iKey)
      
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
      
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

Chỉnh cột bị sót 1 lệnh
If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With

  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)

  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With

  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
  
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Call Dong_3(Rng, iKey)
      
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
      
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

Anh ơi hình như dữ liệu ở các dòng D1:K3 có gì đó sai sai Anh ơi.
Em thấy dữ liệu nó trùng nhau à.
Đối với file DULIEUTIMKIEM1 các sheet(MOQ, LGH,LDH,GIO COLLECT), khi tìm dữ liệu mà không có thì để trống.
trong file DULIEUTIMKIEM-COPY em có làm ví dụ minh họa nơi sheet TIMKIEM. Em có sử dụng công thức.
Em cảm ơn Anh nhiều!

 

[HieuCD]

Anh ơi hình như dữ liệu ở các dòng D1:K3 có gì đó sai sai Anh ơi.
Em thấy dữ liệu nó trùng nhau à.
Đối với file DULIEUTIMKIEM1 các sheet(MOQ, LGH,LDH,GIO COLLECT), khi tìm dữ liệu mà không có thì để trống.
trong file DULIEUTIMKIEM-COPY em có làm ví dụ minh họa nơi sheet TIMKIEM. Em có sử dụng công thức.
Em cảm ơn Anh nhiều!

Chỉnh lại code, thêm lệnh xóa
Rng.ClearContents

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr, Rng As Range
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
 
  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
 
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With
 
  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
    
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Rng.ClearContents
        Call Dong_3(Rng, iKey)
        
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
        
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

 

[huonglien1901]

Chỉnh lại code, thêm lệnh xóa
Rng.ClearContents

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr, Rng As Range
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With

  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)

  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With

  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i

    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Rng.ClearContents
        Call Dong_3(Rng, iKey)
    
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
    
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
    End If
  End With
End Sub

Anh ơi! hình như có cái không đúng Anh ơi.
Em gửi hình cho Anh. Nhà cung cấp đó không có MOQ unit, Order Minimum.
Công ty PHUC SINH cũng không có lịch giao hàng mà code Anh lại kiểm tra có.
Nếu được nhờ Anh kiểm tra giúp em với.
Trường hợp không tìm thấy kết quả thì để trống. cột MOQ unit, Order Minimum, ngày giao hàng, giờ giao hàng.
Có thể định dạng giúp em cột Order Minimum, Purchase price, Sale price dấu phân cách hàng ngàn.

Em cảm ơn Anh.


nhà cung cấp này cũng không có tải nhưng code Anh chạy ra có.



Đây là file DULIEUTIMKIEMEM LÀM BẰNG CÔNG THỨC. Code Anh chạy ra có.


Đây 2 nhà cung cấp MOQ Unit, Oder Minimum không có tải, nhưng Code Anh lại chạy ra có.

3000898	CTY TNHH DINH DUONG OTSUKA THANG	0	-	Thứ Ba,Thứ Sáu,	09h00 - 12h00	15H00	, , Wed, , , ,	1	Week
1000359	CT TNHH THAI CORP INTERNATIONAL(VN)	0	-	Thứ Hai,Thứ Sáu,	09h00 - 12h00	12H00	Mon, , , , , ,	1	Week

 

[HieuCD]

Anh ơi! hình như có cái không đúng Anh ơi.
Em gửi hình cho Anh. Nhà cung cấp đó không có MOQ unit, Order Minimum.
Công ty PHUC SINH cũng không có lịch giao hàng mà code Anh lại kiểm tra có.
Nếu được nhờ Anh kiểm tra giúp em với.
Trường hợp không tìm thấy kết quả thì để trống. cột MOQ unit, Order Minimum, ngày giao hàng, giờ giao hàng.
Có thể định dạng giúp em cột Order Minimum, Purchase price, Sale price dấu phân cách hàng ngàn.

Em cảm ơn Anh.

View attachment 218866
nhà cung cấp này cũng không có tải nhưng code Anh chạy ra có.
View attachment 218872


Đây là file DULIEUTIMKIEMEM LÀM BẰNG CÔNG THỨC. Code Anh chạy ra có.

View attachment 218875
Đây 2 nhà cung cấp MOQ Unit, Oder Minimum không có tải, nhưng Code Anh lại chạy ra có.

3000898	CTY TNHH DINH DUONG OTSUKA THANG	0	-	Thứ Ba,Thứ Sáu,	09h00 - 12h00	15H00	, , Wed, , , ,	1	Week
1000359	CT TNHH THAI CORP INTERNATIONAL(VN)	0	-	Thứ Hai,Thứ Sáu,	09h00 - 12h00	12H00	Mon, , , , , ,	1	Week

Bạn kiểm tra lại, công thức sheet TimKiem sai, kết quả không đúng

 

[huonglien1901]

Bạn kiểm tra lại, công thức sheet TimKiem sai, kết quả không đúng

Anh ơi. em xin lỗi Anh nhiều! kết quả quá là tuyệt vời.
Nhờ Anh 2 vấn đề này là em kết thúc ở đây, kết quả thật là tuyệt.
Nhờ Anh khi trích tự động căn chỉnh dòng và cột.
Có thể định dạng giúp em cột Order Minimum, Purchase price, Sale price dấu phân cách hàng ngàn.
Em cảm ơn Anh nhiều!

 

[HieuCD]

Anh ơi. em xin lỗi Anh nhiều! kết quả quá là tuyệt vời.
Nhờ Anh 2 vấn đề này là em kết thúc ở đây, kết quả thật là tuyệt.
Nhờ Anh khi trích tự động căn chỉnh dòng và cột.
Có thể định dạng giúp em cột Order Minimum, Purchase price, Sale price dấu phân cách hàng ngàn.
Em cảm ơn Anh nhiều!

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
 
  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
 
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With
 
  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
    
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Rng.ClearContents
        Call Dong_3(Rng, iKey)
        
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
        
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
      eRow = Range("A" & Rows.Count).End(xlUp).Row
      Range("E3:F" & eRow).NumberFormat = "#,###;[red](#,###);"
      Cells.EntireColumn.AutoFit
      Cells.EntireRow.AutoFit
    End If
  End With
End Sub

 

[huonglien1901]

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With

  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)

  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With

  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
   
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Rng.ClearContents
        Call Dong_3(Rng, iKey)
       
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
       
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
      eRow = Range("A" & Rows.Count).End(xlUp).Row
      Range("E3:F" & eRow).NumberFormat = "#,###;[red](#,###);"
      Cells.EntireColumn.AutoFit
      Cells.EntireRow.AutoFit
    End If
  End With
End Sub

Kết quả hơn cả mong đợi luôn Anh.
Em cảm ơn Anh rất nhiều.
Em chúc Anh ngày vui.

 

[huonglien1901]

Dim aMOQ, aLGH, aGIOCOLLECT, aLDH

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim eRow As Long, supBln As Boolean, Rng As Range
 
  If Target.Address(0, 0) = "A3" Or Target.Address(0, 0) = "B1" Then
    Call TangToc(False)
    eRow = Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 4 Then Range("A5:K" & eRow).Clear
    Call LungTung
    Call TangToc(True)
  End If
End Sub

Private Sub LungTung()
  Dim sArr(), cArr(), Res(), S, colArr
  Dim i As Long, eRow As Long, sRow As Long, k As Long
  Dim Contract As String, Stastus As String, iKey

  With Sheets("Car order")
    cArr = .Range("B2:F" & .Range("B" & Rows.Count).End(xlUp).Row).Value
  End With
 
  With Sheets("CAR proposal")
    sArr = .Range("C2:AK" & .Range("D" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
 
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(cArr)
      iKey = cArr(i, 1)
      If .exists(iKey) = False Then .Add iKey, cArr(i, 5)
    Next i
    For i = 1 To sRow
      iKey = sArr(i, 1)
      If .exists(iKey) Then sArr(i, 10) = UCase(.Item(iKey)) Else sArr(i, 10) = ""
    Next i
  End With
 
  Stastus = UCase(Left(Range("B1").Value, 3))
  Contract = UCase(Range("A3").Value) & "*"
  With CreateObject("scripting.dictionary")
    For i = 1 To sRow
      If Left(sArr(i, 10), 3) = Stastus Or Len(Stastus) = 0 Then
        If UCase(sArr(i, 4)) Like Contract Then
          iKey = sArr(i, 2)
          If .exists(iKey) = False Then
            k = k + 1
            .Add iKey, Array(i)
          Else
            S = .Item(iKey)
            ReDim Preserve S(0 To UBound(S) + 1)
            S(UBound(S)) = i
            .Item(iKey) = S
          End If
        End If
      End If
    Next i
    
    If k Then
      If TypeName(aMOQ) <> "Variant()" Then Call CreateArr_DuLieuTimkiem
      colArr = Array(, 9, 11, 21, 22, 23, 26, 31, 32, 33, 34, 35)
      k = 0
      For Each iKey In .keys
        eRow = Range("A" & Rows.Count).End(xlUp).Row
        k = k + 1
        If k > 1 Then
          Range("A1:K4").Copy
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteValues
          Range("A" & eRow + 1).PasteSpecial Paste:=xlPasteFormats
          Application.CutCopyMode = False
          eRow = eRow + 4
        End If

        Range("C" & eRow - 1) = iKey
        Set Rng = Range("D" & eRow - 1).Resize(, 8)
        Rng.ClearContents
        Call Dong_3(Rng, iKey)
        
        S = .Item(iKey)
        ReDim Res(0 To UBound(S), 1 To UBound(colArr))
        For n = 0 To UBound(S)
          If n = 0 Then Range("B" & eRow - 1) = sArr(S(n), 3)
          For j = 1 To UBound(colArr)
            Res(n, j) = sArr(S(n), colArr(j))
          Next j
        Next n
        
        Range("A" & eRow + 1).Resize(n).NumberFormat = "@"
        Range("A" & eRow + 1).Resize(n, UBound(colArr)) = Res
        Range("A" & eRow + 1).Resize(n, UBound(colArr)).Borders.LineStyle = 1
        If n > 1 Then Range("A" & eRow + 1).Resize(n, UBound(colArr)).Sort Range("A" & eRow + 1), 1, Header:=xlNo
      Next
      eRow = Range("A" & Rows.Count).End(xlUp).Row
      Range("E3:F" & eRow).NumberFormat = "#,###;[red](#,###);"
      Cells.EntireColumn.AutoFit
      Cells.EntireRow.AutoFit
    End If
  End With
End Sub

Private Sub CreateArr_DuLieuTimkiem()
  Dim wb As Workbook, eRow As Long
 
  Set wb = Workbooks.Open(ThisWorkbook.Path & "\DU LIEU TIM KIEM1.xlsm")
  With wb.Sheets("MOQ")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aMOQ = .Range("B2:H" & eRow).Value
  End With

  With wb.Sheets("LGH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLGH = .Range("B2:I" & eRow).Value
  End With
      
  With wb.Sheets("GIO COLLECT")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aGIOCOLLECT = .Range("A2:C" & eRow).Value
  End With
 
  With wb.Sheets("LDH")
    If .AutoFilterMode = True Then .AutoFilterMode = False
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    If eRow > 1 Then aLDH = .Range("B2:P" & eRow).Value
  End With
  wb.Close False
End Sub

Private Sub Dong_3(ByRef Rng, ByVal iKey As String)
  Dim wb As Workbook, sArr()
  Dim i As Long, eRow As Long, sRow As Long

      sArr = aMOQ
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 4)) > 0 Then
            Rng(1, 1) = sArr(i, 4)
          ElseIf Len(sArr(i, 7)) > 0 Then
            Rng(1, 1) = sArr(i, 7)
          End If
          If Len(sArr(i, 3)) > 0 Then
            Rng(1, 2) = sArr(i, 3)
          ElseIf Len(sArr(i, 5)) > 0 Then
            Rng(1, 2) = sArr(i, 5)
          End If
          Exit For
        End If
      Next i

      sArr = aLGH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 8)) > 0 Then Rng(1, 3) = sArr(i, 8)
          If Len(sArr(i, 3)) > 0 Then Rng(1, 4) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aGIOCOLLECT
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 3)) > 0 Then Rng(1, 5) = sArr(i, 3)
          Exit For
        End If
      Next i

      sArr = aLDH
      sRow = UBound(sArr)
      For i = 1 To sRow
        If sArr(i, 1) = iKey Then
          If Len(sArr(i, 15)) > 0 Then Rng(1, 6) = Replace(Application.Trim(Replace(sArr(i, 15), ",", " ")), " ", ",")
          If Len(sArr(i, 4)) > 0 Then Rng(1, 7) = sArr(i, 4)
          If Len(sArr(i, 5)) > 0 Then Rng(1, 8) = sArr(i, 5)
          Exit For
        End If
      Next i
End Sub

Private Sub TangToc(ByVal Bln As Boolean)
  Application.EnableEvents = Bln
  Application.ScreenUpdating = Bln
End Sub

Anh Hiếu em nhờ Anh thêm vấn đề này nữa.
Khi cùng nhà cung cấp, khác hợp đồng, cùng mã quầy, khác số PO(order No) cùng trạng thái,
có thể tách riêng từng nhà cung cấp ra được không Anh.
trong file nhà cung cấp Tường An có 2 số PO khác nhau cùng 01 quầy(Dept) khác hợp đồng(M......)
Em cảm ơn Anh!