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
