VBA và Vlookup (2 người xem)

Cá ngừ F1 · 22/10/13

E có một file dữ liệu (các code copy của thầy NDU) - có 2 sheet là Data và P22
Code trong Module

Option ExplicitPublic Chk As Boolean, Dic As Object, aResult()
Sub Autpen()
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("P22")
Set SrcRng = wks.Range("A1:K10000")
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

Code trong sheet Data

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 Autpen
If Not Intersect(Range("F2:F10000"), Target) Is Nothing Then
Set rTarget = Intersect(Range("F2:F10000"), 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

E có loay hoay để sửa nhưng mà quay quay cái đầu, chả ra đâu vào đâu $:=\+$ (chưa hiểu bản chất vấn đề)
Lookup_value e để ở Range("F2:F10000") của sheet Data
Giờ muốn tìm kiếm 6 cột bên sheet P22 để đưa vào sheet Data (thay cho hàm vlookup nặng nề) thì code cần thêm/sửa những j

P/S: quả thật file này bảo mật nên ko thể úp lên đây, mong các thầy/anh/chị thông cảm giúp đỡ

dhn46 · 22/10/13

Xem cách bạn hỏi từ những Topic khác dhn46 muốn góp ý như sau:

1/ Đoán Code thì có thể nhưng mất thời gian và độ rủi ro cao, mất công làm lại
2/ Gợi ý sửa code thì chưa chắc bạn đã biết làm đúng và phòng ngừa phát sinh
3/ Để hiểu mà sửa thì mất nhiều thời gian nhất là động tới Object như Coe trên

Đặc biệt muốn góp ý về file mẫu.

File mẫu của mọi người có thể chứa những thông tin riêng và không thể Public nhưng nếu biến đổi cho dữ liệu nó giống thì không phải là không làm được

Bạn có 6 cột tên cụ thể thì bạn chuyển thành a,b,c miẽn là có 6 cái cột
Dữ liệu có tên khách hàng cụ thể thì chuyển thành khách hàng 1, khách hàng 2...
Dữ liệu có số liệu thì "ma" nó đi

Nói chung mất một ít thời gian "xào xáo" mớ dữ liệu ấy thành dữ liệu "ma" miễn đúng Form đúng bản chất thì sẽ có sự giúp đỡ nhanh và sớm nhất.

Quang_Hải · 22/10/13

Cá ngừ F1 đã viết:
E có một file dữ liệu (các code copy của thầy NDU) - có 2 sheet là Data và P22
Code trong Module

P/S: quả thật file này bảo mật nên ko thể úp lên đây, mong các thầy/anh/chị thông cảm giúp đỡ

Theo tựa bài thì muốn thay VlookUp bằng VBA thì nên sử dụng phương thức Find, Offset là gọn nhất. Nhìn code chóng mặt quá

Cá ngừ F1 · 22/10/13

quanghai1969 đã viết:
Theo tựa bài thì muốn thay VlookUp bằng VBA thì nên sử dụng phương thức Find, Offset là gọn nhất. Nhìn code chóng mặt quá

Dạ vâng.. a nhìn còn chóng mặt.. e còn quay quay mấy vòng chưa hiểu chuyện j... e sẽ pốt file sớm.. mong anh/chị giúp đỡ ạh

Cá ngừ F1 · 22/10/13

E xin pốt file cho bài #1, mong các thành viên giúp đỡ ạh

dhn46 · 22/10/13

1/ File của bạn có rất nhiều dữ liệu trùng tại sheet BC => Vậy sẽ phải lấy dữ liệu như thế nào? Lấy cái trước hay cái sau?

2/ File có rất nhiều Code liệu các Code có xung đột nhau không? Có thể loại bỏ code nào? Ví dụ như bạn để sự kiện Worksheet change tại sheet Data trong đó có xoá cột Status => Khi chạy các sub khác sẽ dẫn tới mất dữ liệu.

Bạn có lường tới các Sub mà bạn đã chỉnh sửa chèn vào file xung đột nhau không?

ndu96081631 · 22/10/13

Cá ngừ F1 đã viết:
E xin pốt file cho bài #1, mong các thành viên giúp đỡ ạh

1> Code cho Module3:

Mã:

Public chk As Boolean, dic1 As Object, dic2 As Object, aResult
Sub Auto_Open()
  Dim wks As Worksheet
  Dim lR As Long, lC As Long, n As Long
  Dim tmp As String
  On Error Resume Next
  Set wks = Sheets("BC")
  aResult = wks.Range("A1:I60000").Value
  Set dic1 = CreateObject("Scripting.Dictionary")
  For lR = 1 To UBound(aResult, 1)
    If Len(CStr(aResult(lR, 1))) Then
      tmp = CStr(aResult(lR, 1))
      If Not dic1.Exists(tmp) Then dic1.Add tmp, lR
    End If
  Next
  Dim aSrc, tmp1 As String, tmp2 As String
  Set wks = Sheets("Status")
  aSrc = wks.Range("A1:B60000").Value
  Set dic2 = CreateObject("Scripting.Dictionary")
  For lR = 1 To UBound(aSrc, 1)
    If Len(CStr(aSrc(lR, 1))) Then
      If Len(CStr(aSrc(lR, 2))) Then
        tmp1 = CStr(aSrc(lR, 1))
        tmp2 = CStr(aSrc(lR, 2))
        If Not dic2.Exists(tmp1) Then dic2.Add tmp1, tmp2
      End If
    End If
  Next
End Sub

2> Code cho Sheet DATA:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rTarget As Range, aTarget, lR As Long, n As Long
  Dim arr1(), arr2(), arr3()
  Dim tmp1 As String, tmp2 As String
  On Error Resume Next
  If dic1 Is Nothing Then Auto_Open
  If Not Intersect(Range("F2:F10000"), Target) Is Nothing Then
    Set rTarget = Intersect(Range("F2:F10000"), Target)
    aTarget = rTarget.Value
    If Not IsArray(rTarget.Value) Then
      ReDim aTarget(1 To 1, 1 To 1)
      aTarget(1, 1) = rTarget.Value
    End If
    ReDim arr1(1 To UBound(aTarget, 1), 1 To 1)
    ReDim arr2(1 To UBound(aTarget, 1), 1 To 2)
    ReDim arr3(1 To UBound(aTarget, 1), 1 To 2)
    For lR = 1 To UBound(aTarget, 1)
      If Len(aTarget(lR, 1)) Then
        tmp1 = "_" & aTarget(lR, 1)
        If dic1.Exists(tmp1) Then
          tmp2 = aResult(dic1.Item(tmp1), 7)
          If dic2.Exists(tmp2) Then
            arr1(lR, 1) = dic2.Item(tmp2)
          Else
            arr1(lR, 1) = "Act"
          End If
          arr2(lR, 1) = aResult(dic1.Item(tmp1), 6)
          arr2(lR, 2) = aResult(dic1.Item(tmp1), 5)
          arr3(lR, 1) = aResult(dic1.Item(tmp1), 4)
          arr3(lR, 2) = aResult(dic1.Item(tmp1), 9)
        End If
      End If
    Next
    rTarget.Offset(, 1).Resize(, 1).Value = arr1
    rTarget.Offset(, 6).Resize(, 2).Value = arr2
    rTarget.Offset(, 9).Resize(, 2).Value = arr3
  End If
End Sub

3> Code cho Sheet BC

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  chk = True
End Sub
Private Sub Worksheet_Deactivate()
  If chk Then
    Auto_Open
    chk = False
  End If
End Sub

4> Code cho Sheet Status:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  chk = True
End Sub
Private Sub Worksheet_Deactivate()
  If chk Then
    Auto_Open
    chk = False
  End If
End Sub

Cá ngừ F1 · 22/10/13

ndu96081631 đã viết:

2> Code cho Sheet DATA:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rTarget As Range, aTarget, lR As Long, n As Long
  Dim arr1(), arr2(), arr3()
  Dim tmp1 As String, tmp2 As String
  On Error Resume Next
  If dic1 Is Nothing Then Auto_Open
  If Not Intersect(Range("F2:F10000"), Target) Is Nothing Then
    Set rTarget = Intersect(Range("F2:F10000"), Target)
    aTarget = rTarget.Value
    If Not IsArray(rTarget.Value) Then
      ReDim aTarget(1 To 1, 1 To 1)
      aTarget(1, 1) = rTarget.Value
    End If
    ReDim arr1(1 To UBound(aTarget, 1), 1 To 1)
    ReDim arr2(1 To UBound(aTarget, 1), 1 To 2)
    ReDim arr3(1 To UBound(aTarget, 1), 1 To 2)
    For lR = 1 To UBound(aTarget, 1)
      If Len(aTarget(lR, 1)) Then
        tmp1 = "_" & aTarget(lR, 1)
        If dic1.Exists(tmp1) Then
          tmp2 = aResult(dic1.Item(tmp1), 7)
          If dic2.Exists(tmp2) Then
            arr1(lR, 1) = dic2.Item(tmp2)
          Else
            arr1(lR, 1) = "Act"
          End If
          arr2(lR, 1) = aResult(dic1.Item(tmp1), 6)
          arr2(lR, 2) = aResult(dic1.Item(tmp1), 5)
          arr3(lR, 1) = aResult(dic1.Item(tmp1), 4)
          arr3(lR, 2) = aResult(dic1.Item(tmp1), 9)
        End If
      End If
    Next
    rTarget.Offset(, 1).Resize(, 1).Value = arr1
    rTarget.Offset(, 6).Resize(, 2).Value = arr2
    rTarget.Offset(, 9).Resize(, 2).Value = arr3
  End If
End Sub

[/QUOTE]
Nếu thay cột kết quả ở bên sheet DATA (có thể ko phải là cột G hay L... như ví dụ) thì thay ở đoạn code nào hả thầy?

ndu96081631 · 22/10/13

Cá ngừ F1 đã viết:
Nếu thay cột kết quả ở bên sheet DATA (có thể ko phải là cột G hay L... như ví dụ) thì thay ở đoạn code nào hả thầy?

Bạn chỉ cần thay đổi 1 chút thôi thì code phải thay đổi rất nhiều
Ví dụ:
- Hiện tại kết quả nằm tại G, L, M, O, P
- Ta thấy 5 cột này không nằm kề nhau và đang chia thành 3 vùng gồm cột Cột G là 1 vùng, cột L:M là 1 vùng và cột O

là 1 vùng . Vậy nên cần có 3 biến array (arr1, arr2 và arr3)
- Đoạn code:

Mã:

rTarget.Offset(, 1).Resize(, 1).Value = arr1
rTarget.Offset(, 6).Resize(, 2).Value = arr2
rTarget.Offset(, 9).Resize(, 2).Value = arr3

3 dòng code dùng để gán kết quả vào 3 vùng

Cá ngừ F1 · 23/10/13

Private Sub Worksheet_Change(ByVal Target As Range) Dim rTarget As Range, aTarget, lR As Long, n As Long
Dim arr1(), arr2()
Dim tmp1 As String, tmp2 As String
On Error Resume Next
If dic1 Is Nothing Then Autpen
If Not Intersect(Range("F2:F10000"), Target) Is Nothing Then
Set rTarget = Intersect(Range("F2:F10000"), Target)
aTarget = rTarget.Value
If Not IsArray(rTarget.Value) Then
ReDim aTarget(1 To 1, 1 To 1)
aTarget(1, 1) = rTarget.Value
End If
ReDim arr1(1 To UBound(aTarget, 1), 1 To 1)
ReDim arr2(1 To UBound(aTarget, 1), 1 To 4)
For lR = 1 To UBound(aTarget, 1)
If Len(aTarget(lR, 1)) Then
tmp1 = "_" & aTarget(lR, 1)
If dic1.Exists(tmp1) Then
tmp2 = aResult(dic1.Item(tmp1), 7)
If dic2.Exists(tmp2) Then
arr1(lR, 1) = dic2.Item(tmp2)
Else
arr1(lR, 1) = "Act"
End If
arr2(lR, 1) = aResult(dic1.Item(tmp1), 4)
arr2(lR, 2) = aResult(dic1.Item(tmp1), 5)
arr2(lR, 3) = aResult(dic1.Item(tmp1), 6)
arr2(lR, 4) = aResult(dic1.Item(tmp1), 9)
End If
End If
Next
rTarget.Offset(, 1).Resize(, 1).Value = arr1
rTarget.Offset(, 36).Resize(, 4).Value = arr2
End If
End Sub

Sau khi loay hoay thì e cũng tự sửa để áp dụng vào file của mình.. đầu cứ ong ong, hjk
Cho e hỏi thêm chút, cái sheet DATA đó ngoài mảng F2:F10000 làm lookup_value
Còn có những mảng khác để lookup_value đến sheet BC thì ở sheet DATA lại khai báo thêm đoạn code

Private Sub Worksheet_Change(ByVal Target As Range) Dim rTarget As Range, aTarget, lR As Long, n As Long
Dim arr4(), arr5(), arr6() 'gia dịnh vẫn có 3 màng
Dim tmp1 As String, tmp2 As String
On Error Resume Next
If dic1 Is Nothing Then Autpen
If Not Intersect(Range("AC2:AC10000"), Target) Is Nothing Then '
Set rTarget = Intersect(Range("AC2:AC10000"), Target)
aTarget = rTarget.Value
If Not IsArray(rTarget.Value) Then
ReDim aTarget(1 To 1, 1 To 1) aTarget(1, 1) = rTarget.Value
.......

Còn Các thông số khác e mò mẫm có thể đổi được ạh

ndu96081631 · 23/10/13

Cá ngừ F1 đã viết:
Sau khi loay hoay thì e cũng tự sửa để áp dụng vào file của mình.. đầu cứ ong ong, hjk
Cho e hỏi thêm chút, cái sheet DATA đó ngoài mảng F2:F10000 làm lookup_value
Còn có những mảng khác để lookup_value đến sheet BC thì ở sheet DATA lại khai báo thêm đoạn code

Còn Các thông số khác e mò mẫm có thể đổi được ạh

Nếu thay đổi vùng lookup thì đoạn cuối: rTarget.Offset(...).Resize(...) cũng phải thay đổi luôn nha. Tự bạn tính toán xem phải Offset bao nhiêu cột và resize bao nhiêu cột nhé (đếm bằng tay)

Cá ngừ F1 · 23/10/13

ndu96081631 đã viết:
Nếu thay đổi vùng lookup thì đoạn cuối: rTarget.Offset(...).Resize(...) cũng phải thay đổi luôn nha. Tự bạn tính toán xem phải Offset bao nhiêu cột và resize bao nhiêu cột nhé (đếm bằng tay)

Dạ, ý e ko phải là thay đổi vùng lookup.. mà là có thêm mảng (ví dụ "X2:X10000") để làm lookup_value

ndu96081631 · 23/10/13

Cá ngừ F1 đã viết:
Dạ, ý e ko phải là thay đổi vùng lookup.. mà là có thêm mảng (ví dụ "X2:X10000") để làm lookup_value

Vậy thì bạn phải If 2 lần. Ví dụ:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rTarget As Range, aTarget, lR As Long, n As Long
  Dim arr1(), arr2(), arr3()
  Dim tmp1 As String, tmp2 As String
  On Error Resume Next
  If dic1 Is Nothing Then Auto_Open
  If Not Intersect(Range("F2:F10000"), Target) Is Nothing Then
    'Gì gì đó
    rTarget.Offset(, 1).Resize(, 1).Value = arr1
    rTarget.Offset(, 6).Resize(, 2).Value = arr2
    rTarget.Offset(, 9).Resize(, 2).Value = arr3
  [COLOR=#ff0000]ElseIf Not Intersect(Range("X2:X10000"), Target) Is Nothing Then[/COLOR]
  [COLOR=#ff0000]  'Làm tương tự như trên
  End If[/COLOR]
End Sub

Cá ngừ F1 · 23/10/13

E làm thêm đoạn này

Mã:

Next    rTarget.Offset(, 1).Resize(, 1).Value = arr1
    rTarget.Offset(, 36).Resize(, 4).Value = arr2
  ElseIf Not Intersect(Range("AC2:AC10000"), Target) Is Nothing Then
  Set rTarget = Intersect(Range("AC2:AC10000"), Target)
    aTarget = rTarget.Value
    If Not IsArray(rTarget.Value) Then
      ReDim aTarget(1 To 1, 1 To 1)
      aTarget(1, 1) = rTarget.Value
    End If
    ReDim arr1(1 To UBound(aTarget, 1), 1 To 1)
    ReDim arr2(1 To UBound(aTarget, 1), 1 To 1)
    For lR = 1 To UBound(aTarget, 1)
      If Len(aTarget(lR, 1)) Then
        tmp1 = "_" & aTarget(lR, 1)
        If dic1.Exists(tmp1) Then
          tmp2 = aResult(dic1.Item(tmp1), 7)
          If dic2.Exists(tmp2) Then
            arr1(lR, 1) = dic2.Item(tmp2)
          Else
            arr1(lR, 1) = "Act"
          End If
          arr2(lR, 1) = aResult(dic1.Item(tmp1), 9)
          End If
          Next
    rTarget.Offset(, 5).Resize(, 1).Value = arr1
    rTarget.Offset(, 16).Resize(, 1).Value = arr2
  End If
End Sub

Thì báo lỗi next without for ??? giúp em với ạh

ndu96081631 · 23/10/13

Cá ngừ F1 đã viết:

E làm thêm đoạn này

Mã:

Next    rTarget.Offset(, 1).Resize(, 1).Value = arr1
    rTarget.Offset(, 36).Resize(, 4).Value = arr2
  ElseIf Not Intersect(Range("AC2:AC10000"), Target) Is Nothing Then
  Set rTarget = Intersect(Range("AC2:AC10000"), Target)
    aTarget = rTarget.Value
    If Not IsArray(rTarget.Value) Then
      ReDim aTarget(1 To 1, 1 To 1)
      aTarget(1, 1) = rTarget.Value
    End If
    ReDim arr1(1 To UBound(aTarget, 1), 1 To 1)
    ReDim arr2(1 To UBound(aTarget, 1), 1 To 1)
    For lR = 1 To UBound(aTarget, 1)
      If Len(aTarget(lR, 1)) Then
        tmp1 = "_" & aTarget(lR, 1)
        If dic1.Exists(tmp1) Then
          tmp2 = aResult(dic1.Item(tmp1), 7)
          If dic2.Exists(tmp2) Then
            arr1(lR, 1) = dic2.Item(tmp2)
          Else
            arr1(lR, 1) = "Act"
          End If
          arr2(lR, 1) = aResult(dic1.Item(tmp1), 9)
          End If
          Next
    rTarget.Offset(, 5).Resize(, 1).Value = arr1
    rTarget.Offset(, 16).Resize(, 1).Value = arr2
  End If
End Sub

Thì báo lỗi next without for ??? giúp em với ạh

Thì bạn tự đếm đi: Có mấy cái IF và có mấy cái End If

Cá ngừ F1 · 23/10/13

ndu96081631 đã viết:
Thì bạn tự đếm đi: Có mấy cái IF và có mấy cái End If

Mã:

arr2(lR, 1) = aResult(dic1.Item(tmp1), 9)          End If
          Next
[COLOR=#ff0000]          End If[/COLOR]
    rTarget.Offset(, 5).Resize(, 1).Value = arr1
    rTarget.Offset(, 16).Resize(, 1).Value = arr2
  End If

Dạ.. thêm 1 cái End if sau next --> ko báo lỗi j --> nhưng buồn thay cũng chả có kết quả j )(&&@@

Quang_Hải · 23/10/13

Mình đọc không nổi cái rừng của anh NDU nhưng nếu chỉ muốn thay mấy cái Vlookup đó thì bạn copy code này thử xem. Code mình viết thuộc dạng dưới cả căn bản nên dể chỉnh sửa. Tuy nhiên dữ liệu của bạn bị trùng thì Vookup chỉ tìm ra giá trị đầu thôi

PHP:

Sub VlookUp2()
Dim LookUpValue(), DesArr1(), DesArr2(), DesArr3(), i As Long, j As Long
Dim String1 As Range, String2 As String, String3 As Range
With Sheets("DATA")
   LookUpValue = .Range(.[F2], .[F65536].End(3)).Value
End With
ReDim DesArr1(1 To UBound(LookUpValue), 1 To 1)
ReDim DesArr2(1 To UBound(LookUpValue), 1 To 2)
ReDim DesArr3(1 To UBound(LookUpValue), 1 To 2)
For i = 1 To UBound(LookUpValue)
   Set String1 = Sheets("BC").[A:A].Find("_" & LookUpValue(i, 1), , , 1)
   If Not String1 Is Nothing Then
      Set String3 = Sheets("Status").[A:A].Find(String1.Offset(, 6), , , 1)
      If Not String3 Is Nothing Then
         DesArr1(i, 1) = String3.Offset(, 1)
      End If
      DesArr2(i, 1) = String1.Offset(, 5)
      DesArr2(i, 2) = String1.Offset(, 4)
      DesArr3(i, 1) = String1.Offset(, 3)
      DesArr3(i, 2) = String1.Offset(, 8)
   End If
Next
Sheets("DATA").[G2].Resize(i - 1) = DesArr1
Sheets("DATA").[L2].Resize(i - 1, 2) = DesArr2
Sheets("DATA").[O2].Resize(i - 1, 2) = DesArr3
End Sub

ndu96081631 · 23/10/13

Cá ngừ F1 đã viết:
Mã:

arr2(lR, 1) = aResult(dic1.Item(tmp1), 9) End If Next [COLOR=#ff0000] End If[/COLOR] rTarget.Offset(, 5).Resize(, 1).Value = arr1 rTarget.Offset(, 16).Resize(, 1).Value = arr2 End If

Dạ.. thêm 1 cái End if sau next --> ko báo lỗi j --> nhưng buồn thay cũng chả có kết quả j

Tô màu từng cặp if sẽ thấy:

Mã:

    Next    
      rTarget.Offset(, 1).Resize(, 1).Value = arr1
      rTarget.Offset(, 36).Resize(, 4).Value = arr2
  [COLOR=#ff0000]ElseIf Not Intersect(Range("AC2:AC10000"), Target) Is Nothing Then[/COLOR]
    Set rTarget = Intersect(Range("AC2:AC10000"), Target)
    aTarget = rTarget.Value
    If Not IsArray(rTarget.Value) Then
      ReDim aTarget(1 To 1, 1 To 1)
      aTarget(1, 1) = rTarget.Value
    End If
    ReDim arr1(1 To UBound(aTarget, 1), 1 To 1)
    ReDim arr2(1 To UBound(aTarget, 1), 1 To 1)
    For lR = 1 To UBound(aTarget, 1)
      [COLOR=#0000cd]If Len(aTarget(lR, 1)) Then[/COLOR]
        tmp1 = "_" & aTarget(lR, 1)
        [COLOR=#006400]If dic1.Exists(tmp1) Then[/COLOR]
          tmp2 = aResult(dic1.Item(tmp1), 7)
          If dic2.Exists(tmp2) Then
            arr1(lR, 1) = dic2.Item(tmp2)
          Else
            arr1(lR, 1) = "Act"
          End If
          arr2(lR, 1) = aResult(dic1.Item(tmp1), 9)
        [COLOR=#006400]End If[/COLOR]
    Next
      rTarget.Offset(, 5).Resize(, 1).Value = arr1
      rTarget.Offset(, 16).Resize(, 1).Value = arr2
  [COLOR=#ff0000]End If[/COLOR]
End Sub

Cái End If cho cái If màu xanh dương ở đâu?
Bới vậy khi viết code, ta bố trí đàng hoàng, thụt vào thụt ra từng cặp IF.. End IF, For.. Next vân vân.. sẽ thấy ngay đang thiếu chổ nào liền

Cá ngừ F1 · 23/10/13

Mã:

 rTarget.Offset(, 1).Resize(, 1).Value = arr1
    rTarget.Offset(, 36).Resize(, 4).Value = arr2
  ElseIf Not Intersect(Range("AC2:AC10000"), Target) Is Nothing Then
    Set rTarget = Intersect(Range("AC2:AC10000"), Target)
    aTarget = rTarget.Value
    If Not IsArray(rTarget.Value) Then
      ReDim aTarget(1 To 1, 1 To 1)
      aTarget(1, 1) = rTarget.Value
    End If
    ReDim arr1(1 To UBound(aTarget, 1), 1 To 1)
    ReDim arr2(1 To UBound(aTarget, 1), 1 To 1)
    For lR = 1 To UBound(aTarget, 1)
[COLOR=#0000cd]      If Len(aTarget(lR, 1)) Then[/COLOR]
        tmp1 = "_" & aTarget(lR, 1)
        If dic1.Exists(tmp1) Then
          tmp2 = aResult(dic1.Item(tmp1), 7)
          If dic2.Exists(tmp2) Then
            arr1(lR, 1) = dic2.Item(tmp2)
          Else
            arr1(lR, 1) = "Act"
          End If
[COLOR=#ff0000]          arr2(lR, 1) = aResult(dic1.Item(tmp1), 9)[/COLOR]
        End If
[COLOR=#0000cd]      End If[/COLOR]
    Next
      rTarget.Offset(, 5).Resize(, 1).Value = arr1
[COLOR=#ff0000]      rTarget.Offset(, 16).Resize(, 1).Value = arr2[/COLOR]
  End If
End Sub

Thêm vào đây đúng ko ạh --> ko còn lỗi --> nhưng kết quả thì ko thấy j? liệu có phải do khai báo biến ở chỗ e bôi đỏ

ndu96081631 · 23/10/13

Cá ngừ F1 đã viết:
[
Thêm vào đây đúng ko ạh --> ko còn lỗi --> nhưng kết quả thì ko thấy j? liệu có phải do khai báo biến ở chỗ e bôi đỏ

Thêm vậy đúng rồi! Còn cái chuyện code chạy đúng sai tôi làm sao biết được (có thấy dữ liệu của bạn đâu mà biết)

VBA và Vlookup (2 người xem)

Người dùng đang xem chủ đề này

( ͡° ͜ʖ ͡°)

Hướng tới tương lai

Thành viên gạo cội

( ͡° ͜ʖ ͡°)

( ͡° ͜ʖ ͡°)

File đính kèm

Hướng tới tương lai

Huyền thoại GPE

( ͡° ͜ʖ ͡°)

Huyền thoại GPE

( ͡° ͜ʖ ͡°)

Huyền thoại GPE

( ͡° ͜ʖ ͡°)

Huyền thoại GPE

( ͡° ͜ʖ ͡°)

Huyền thoại GPE

( ͡° ͜ʖ ͡°)

Thành viên gạo cội

Huyền thoại GPE

( ͡° ͜ʖ ͡°)

Huyền thoại GPE

Đếm ngược thời gian