- Tham gia
- 5/6/08
- Bài viết
- 30,703
- Được thích
- 53,953
Làm thử trên file của bạn nhé:
Mô tả:
- Nhập liệu tại cột C
- Cột D, E, G, H, I và N là những cột cần lookup
- Vậy, nếu nhập liệu 1 hoặc nhiều cell trên cột C thì những cột D, E, G, H, I và N với dòng tương ứng sẽ lấy dữ liệu từ sheet LLNV gán vào
- Nếu 1 hoặc nhiều cell trên 1 C bị xóa thì thì những cột D, E, G, H, I và N với dòng tương ứng cũng sẽ bị xóa theo
Mô tả đúng chứ?
Nếu là vậy thì tôi để xuất code thế này:
1> Nạp Dictionary
PHP:
Public Chk As Boolean, Dic As Object, aResult()
Sub Auto_Open()
Dim wks As Worksheet, SrcRng As Range, sArray
Dim lR As Long, i As Long, n As Long, tmp
On Error Resume Next
Set wks = Sheets("LLNV")
Set SrcRng = wks.Range("B6:R1000")
sArray = SrcRng.Value
ReDim aResult(1 To UBound(sArray, 1), 1 To UBound(sArray, 2))
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(sArray, 1)
If CStr(sArray(i, 1)) <> "" Then
tmp = sArray(i, 1)
If Not Dic.Exists(tmp) Then
lR = lR + 1
Dic.Add tmp, lR
aResult(lR, 1) = tmp
aResult(lR, 2) = sArray(i, 2)
aResult(lR, 3) = sArray(i, 3)
aResult(lR, 5) = sArray(i, 5)
aResult(lR, 6) = sArray(i, 6)
aResult(lR, 14) = sArray(i, 14)
aResult(lR, 13) = sArray(i, 13)
End If
End If
Next
End Sub
PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
Chk = True
End Sub
PHP:
Private Sub Worksheet_Deactivate()
If Chk Then
Auto_Open
Chk = False
End If
End Sub
PHP:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rTarget As Range, aTarget, i As Long, n As Long
Dim Arr1(), Arr2(), Arr3(), tmp
On Error Resume Next
If Dic Is Nothing Then Auto_Open
If Not Intersect(Range("C6:C1000"), Target) Is Nothing Then
Set rTarget = Intersect(Range("C6:C1000"), Target)
If IsArray(rTarget.Value) Then
aTarget = rTarget.Value
Else
ReDim aTarget(1 To 1, 1 To 1)
aTarget(1, 1) = rTarget.Value
End If
ReDim Arr1(1 To UBound(aTarget, 1), 1 To 2)
ReDim Arr2(1 To UBound(aTarget, 1), 1 To 3)
ReDim Arr3(1 To UBound(aTarget, 1), 1 To 1)
For i = 1 To UBound(aTarget, 1)
If aTarget(i, 1) <> "" Then
tmp = aTarget(i, 1)
If Dic.Exists(tmp) Then
Arr1(i, 1) = aResult(Dic.Item(tmp), 2)
Arr1(i, 2) = aResult(Dic.Item(tmp), 3)
Arr2(i, 1) = aResult(Dic.Item(tmp), 5)
Arr2(i, 2) = aResult(Dic.Item(tmp), 6)
Arr2(i, 3) = aResult(Dic.Item(tmp), 14)
Arr3(i, 1) = aResult(Dic.Item(tmp), 13)
End If
End If
Next
rTarget.Offset(, 1).Resize(, 2).Value = Arr1
rTarget.Offset(, 4).Resize(, 3).Value = Arr2
rTarget.Offset(, 11).Resize(, 1).Value = Arr3
End If
End Sub(Nói thiệt, làm mấy bài này chán bỏ xừ... lại hại não)
Lần chỉnh sửa cuối:
