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

Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
Cá ngừ F1

Cá ngừ F1

( ͡° ͜ʖ ͡°)
Thành viên BQT
Moderator
Tham gia
1/1/08
Bài viết
2,579
Được thích
3,723
Donate (Momo)
Donate
Giới tính
Nam
Nghề nghiệp
Quan hệ.. và quan hệ..
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 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("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
Nhấp chuột vào đây để mở rộng...
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 Auto_Open
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
Nhấp chuột vào đây để mở rộng...
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 đỡ
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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.
 
Upvote 0
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 đỡ
Nhấp chuột vào đây để mở rộng...
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á
 
Upvote 0
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á
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
E xin pốt file cho bài #1, mong các thành viên giúp đỡ ạh
 

File đính kèm

Upvote 0
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?
 
Upvote 0
Cá ngừ F1 đã viết:
E xin pốt file cho bài #1, mong các thành viên giúp đỡ ạh
Nhấp chuột vào đây để mở rộng...

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
 
Upvote 0
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?
Nhấp chuột vào đây để mở rộng...
 
Upvote 0
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?
Nhấp chuột vào đây để mở rộng...

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:P 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
 
Upvote 0
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 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 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
Nhấp chuột vào đây để mở rộng...
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 Auto_Open
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
.......
Nhấp chuột vào đây để mở rộng...
Còn Các thông số khác e mò mẫm có thể đổi được ạh
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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)
 
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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
 
Upvote 0
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
Next.jpg
 
Lần chỉnh sửa cuối:
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

Thì bạn tự đếm đi: Có mấy cái IF và có mấy cái End If
 
Upvote 0
ndu96081631 đã viết:
Thì bạn tự đếm đi: Có mấy cái IF và có mấy cái End If
Nhấp chuột vào đây để mở rộng...
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 )(&&@@
 
Upvote 0
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
 
Lần chỉnh sửa cuối:
Upvote 0
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 )(&&@@
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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 đỏ
 
Upvote 0
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 đỏ
Nhấp chuột vào đây để mở rộng...

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)
 
Upvote 0
E xin gửi file ạh
Thêm 1 trường Ma1 và D1.. thầy xem giúp e ạh
 

File đính kèm

Upvote 0
Cá ngừ F1 đã viết:
E xin gửi file ạh
Thêm 1 trường Ma1 và D1.. thầy xem giúp e ạh
Nhấp chuột vào đây để mở rộng...

Code của bạn là:
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
        [COLOR=#ff0000]tmp1 = "_" & aTarget(lR, 1)[/COLOR]
        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
  ElseIf Not Intersect(Range("J2:J10000"), Target) Is Nothing Then
    Set rTarget = Intersect(Range("J2:J10000"), 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
        [COLOR=#ff0000]tmp1 = "_" & aTarget(lR, 1)[/COLOR]
        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
      End If
    Next
    rTarget.Offset(, 1).Resize(, 1).Value = arr1
    rTarget.Offset(, 7).Resize(, 1).Value = arr2
  End If
End Sub
Để ý 2 đoạn màu đỏ tôi đánh dấu
- Đoạn màu đỏ ở trên: Do MÃ của ta không có dấu _ ở đâu nên biến Tmp ta phải tự thêm vào (tmp1 = "_" & aTarget(lR, 1))
- Đoạn màu đỏ ở dưới: Mã 1 tại cột J của bạn đã có dấu _ rồi, vậy thì thêm vào là THỪA và làm code chạy trật lật (do không tìm thấy
Vậy, đoạn màu đỏ ở dưới chỉ cần vầy: tmp1 = aTarget(lR, 1)
Hợp lý không?
 
Upvote 0
Dạ, e xin phép LÁI XE
Mã: 
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 Auto_Open
  If Not Intersect(Range([B]"F2:F10000"[/B]), Target) Is Nothing Then
    Set rTarget = Intersect(Range([B]"F2:F10000"[/B]), 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
  ElseIf Not Intersect(Range([B]"AC2:AC10000"[/B]), Target) Is Nothing Then
    Set rTarget = Intersect(Range([B]"AC2:AC10000"[/B]), 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
      End If
    Next
      rTarget.Offset(, 5).Resize(, 1).Value = arr1
      rTarget.Offset(, 17).Resize(, 1).Value = arr2
  ElseIf Not Intersect(Range([B]"AJ2:AJ10000"[/B]), Target) Is Nothing Then
    Set rTarget = Intersect(Range([B]"AJ2:AJ10000"[/B]), 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
      End If
    Next
      rTarget.Offset(, 5).Resize(, 1).Value = arr1
      rTarget.Offset(, 11).Resize(, 1).Value = arr2
  End If
End Sub
Bảng tính của e có 3 mảng lookup_value. Sử dụng hàm theo kiểu truyền thống phải mất vài giây tính toán.
Những j thầy đã chỉ dậy, file chạy thực sự nhanh, mặc dù các mảng dữ liệu khá lơn...
Có thể nói câu này thành hơi sáo ngữ nhưng em vẫn nói "Cảm ơn thầy",
Mong đợi những bài học tiếp theo!!!
 
Upvote 0
Cá ngừ F1 đã viết:
E xin gửi file ạh
Thêm 1 trường Ma1 và D1.. thầy xem giúp e ạh
Nhấp chuột vào đây để mở rộng...
Cho e hỏi bổ đề thêm chút.. e xin phép pốt tiếp vào đây cho liền mạch.. file lấy ở bài #21
Câu hỏi như sau:
- Làm sao có thể triết xuất ra 1 báo cáo để lấy những Mã có trong sheets("BC").range(A:A) mà không có trong sheets("data").range("F:F") và sheets("data").range("J:J")
 

File đính kèm

Upvote 0
Cá ngừ F1 đã viết:
Cho e hỏi bổ đề thêm chút.. e xin phép pốt tiếp vào đây cho liền mạch.. file lấy ở bài #21
Câu hỏi như sau:
- Làm sao có thể triết xuất ra 1 báo cáo để lấy những Mã có trong sheets("BC").range(A:A) mà không có trong sheets("data").range("F:F") và sheets("data").range("J:J")
Nhấp chuột vào đây để mở rộng...

Đây là bài toán khác rồi (không thuộc chủ đề topic này)
Bài toán:
- Tìm kiếm dữ liệu tồn tại trong List1 và List2
- Tìm kiếm dữ liệu tồn tại trong List1 mà không tồn tại trong List2
- Tìm kiếm dữ liệu tồn tại trong List2 mà không tồn tại trong List1
3 bài toán tìm kiếm dạng trên đã post trên diễn đàn mấy chục lần rồi... có thể dùng phương pháp thủ công (advanced filter) hoặc viết code tùy ý
Bạn tìm đí
Nhớ rằng: Không được hỏi chen ngang 1 chủ đề không liên quan nha
 
Upvote 0
Sau khi LÁI XE khá tốt (#23) ..có một số vướng mắc sau ạh
sau khi sheet BC thay đổi số liệu..thì ko thấy bên sheet data thay đổi số liệu, vậy phải thêm động tác nào vào nữa ạh...
 
Upvote 0
Cá ngừ F1 đã viết:
Sau khi LÁI XE khá tốt (#23) ..có một số vướng mắc sau ạh
sau khi sheet BC thay đổi số liệu..thì ko thấy bên sheet data thay đổi số liệu, vậy phải thêm động tác nào vào nữa ạh...
Nhấp chuột vào đây để mở rộng...
E test thử bằng cách: cho sheet BC số liệu khác sau đó copy/paste lại mã ở Data thì mới thấy có tác dụng, nhưng mà nếu thêm đoạn code để copy/paste lại một loạt mã số thì e hơi CÙI BẮP ạh...
 
Upvote 0
Cá ngừ F1 đã viết:
E test thử bằng cách: cho sheet BC số liệu khác sau đó copy/paste lại mã ở Data thì mới thấy có tác dụng, nhưng mà nếu thêm đoạn code để copy/paste lại một loạt mã số thì e hơi CÙI BẮP ạh...
Nhấp chuột vào đây để mở rộng...
Các thầy/anh/chị giúp e với ạh, file thử nghiệm có thể lấy ở bài #24 ạh
 
Upvote 0
quanghai1969 đã viết:
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
Nhấp chuột vào đây để mở rộng...
E có làm theo cách của a quanghai1969
Giả sử file có thêm mảng lookup value thì code cần thêm j ạh (ngoài mảng LookUpValue = .Range(.[F2], .[F65536].End(3)).Value), giả sử X2:X65536 chẳng hạn
E cảm ơn!
 
Upvote 0
Cá ngừ F1 đã viết:
E có làm theo cách của a quanghai1969
Giả sử file có thêm mảng lookup value thì code cần thêm j ạh (ngoài mảng LookUpValue = .Range(.[F2], .[F65536].End(3)).Value), giả sử X2:X65536 chẳng hạn
E cảm ơn!
Nhấp chuột vào đây để mở rộng...
Mình thuộc dạng người có IQ thấp nên thấy file có kèm công thức minh hoạ thì tìm cách, không có file thì hướng dẫn trật là cái chắc
 
Upvote 0
quanghai1969 đã viết:
Mình thuộc dạng người có IQ thấp nên thấy file có kèm công thức minh hoạ thì tìm cách, không có file thì hướng dẫn trật là cái chắc
Nhấp chuột vào đây để mở rộng...
E xin pốt file ạh
- Giả sử file có thêm range lookup value ở cột Ma2 [D2:D65356]
- Thêm vào code để tìm kiếm kết quả ở status2, D2 (vẫn lấy từ sheet BC ạh)
Status2 vẫn lấy tham chiếu như status
D2 lấy tham chiếu như D1
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Cá ngừ F1 đã viết:
E xin pốt file ạh
- Giả sử file có thêm range lookup value ở cột Ma2 [D2:D65356]
- Thêm vào code để tìm kiếm kết quả ở status2, D2 (vẫn lấy từ sheet BC ạh)
Status2 vẫn lấy tham chiếu như status
D2 lấy tham chiếu như D1
Nhấp chuột vào đây để mở rộng...
Thêm như thế này chắc là được nhưng đọc code thấy như cái rừng ớn thiệt
Mã: 
Sub VlookUp2()
Dim LookUpValue(), LookupValue2(), DesArr1(), DesArr2(), DesArr3(), DesArr4()
Dim String1 As Range, String2 As Range, String3 As Range, i As Long, j As Long
With Sheets("DATA")
   LookUpValue = .Range(.[F2], .[F65536].End(3)).Value
   LookupValue2 = .Range(.[d2], .[D65536].End(3)).Value
   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)
   ReDim DesArr4(1 To UBound(LookUpValue), 1 To 2)
   For i = 1 To UBound(LookUpValue)
      Set String1 = Sheets("BC").[A:A].Find("_" & LookUpValue(i, 1), , , 1)
      Set String2 = Sheets("BC").[A:A].Find("_" & LookupValue2(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
      If Not String2 Is Nothing Then
         Set String3 = Sheets("Status").[A:A].Find(String2.Offset(, 6), , , 1)
         If Not String3 Is Nothing Then
            DesArr4(i, 1) = String3.Offset(, 1)
         End If
         DesArr4(i, 2) = String2.Offset(, 8)
      End If
   Next
   .[G2].Resize(i - 1) = DesArr1
   .[L2].Resize(i - 1, 2) = DesArr2
   .[O2].Resize(i - 1, 2) = DesArr3
   .[Q2].Resize(i - 1, 2) = DesArr4
End With
End Sub
 
Upvote 0
Dạ..cảm ơn a..đi đường rừng mà nhanh hơn thì cũng phải triển thôi...
 
Upvote 0
quanghai1969 đã viết:
Thêm như thế này chắc là được nhưng đọc code thấy như cái rừng ớn thiệt
Mã: 
Sub VlookUp2()
Dim LookUpValue(), LookupValue2(), DesArr1(), DesArr2(), DesArr3(), DesArr4()
Dim String1 As Range, String2 As Range, String3 As Range, i As Long, j As Long
With Sheets("DATA")
   LookUpValue = .Range(.[F2], .[F65536].End(3)).Value
   LookupValue2 = .Range(.[d2], .[D65536].End(3)).Value
   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)
   ReDim DesArr4(1 To UBound(LookUpValue), 1 To 2)
   For i = 1 To UBound(LookUpValue)
      Set String1 = Sheets("BC").[A:A].Find("_" & LookUpValue(i, 1), , , 1)
      Set String2 = Sheets("BC").[A:A].Find("_" & LookupValue2(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
      If Not String2 Is Nothing Then
         Set String3 = Sheets("Status").[A:A].Find(String2.Offset(, 6), , , 1)
         If Not String3 Is Nothing Then
            DesArr4(i, 1) = String3.Offset(, 1)
         End If
         DesArr4(i, 2) = String2.Offset(, 8)
      End If
   Next
   .[G2].Resize(i - 1) = DesArr1
   .[L2].Resize(i - 1, 2) = DesArr2
   .[O2].Resize(i - 1, 2) = DesArr3
   .[Q2].Resize(i - 1, 2) = DesArr4
End With
End Sub
Nhấp chuột vào đây để mở rộng...
code đang ko chạy ạh
New Picture (21).jpg
 
Upvote 0
quanghai1969 đã viết:
Lúc này cước 3g đắt quá nên up file ngại lắm.
Nhấp chuột vào đây để mở rộng...
Sao anh không Xóa bớt dòng ở Sheet BC đi cho nhẹ.
Cái món Array khó nhai quá anh ạ, híc ...
Bạn Cá ngừ F1 gửi file cũng nên giảm bớt dung lượng file, dạo này 3G tăng cước, buổi tối mình online chút xíu hết 10k, chắc phải chuyển qua wifi thôi.
 
Upvote 0
leonguyenz đã viết:
Sao anh không Xóa bớt dòng ở Sheet BC đi cho nhẹ.
Cái món Array khó nhai quá anh ạ, híc ...
Bạn Cá ngừ F1 gửi file cũng nên giảm bớt dung lượng file, dạo này 3G tăng cước, buổi tối mình online chút xíu hết 10k, chắc phải chuyển qua wifi thôi.
Nhấp chuột vào đây để mở rộng...
Àh.. lúc đấy úp có wf free mà... chả mấy khi..hí hí
 
Upvote 0
Iq của anh to bự luôn !? Em copy được rất nhiều code của anh sử dụng tuyệt vời ...xúc tích ngắn gọn và những người chưa từng được học lấy một ngày về code như em vẫn đọc và hữu tí ti vận dụng được là một điều trên cả tuyệt vời... Sư phụ ...hic hic
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

L
File Excel nặng chưa tìm được lý do ở đâu . Mong các bác hỗ trợ ! (3 người xem)
Trả lời
5
Đọc
76
PhanTuHuong
PhanTuHuong
H
Tổng hợp Công Nợ theo Công trình
Trả lời
13
Đọc
140
le_vis
L
U
VB tính tổng số cell trong 1 hàng có cùng màu với 1 cell so sánh ở cột khác (1 người xem)
Trả lời
5
Đọc
49
Hoàng Tuấn 868
H
T
VBA LẤY THÔNG TIN TRÊN TỜ KHAI NHẬP KHẨU (1 người xem)
Trả lời
10
Đọc
589
binhminh1408
B
H
Giúp mình ghép nhiều file thành một file. (1 người xem)
Trả lời
10
Đọc
388
hanhnguyen120221cuty
H
Nguyễn Duy Tuân
Hàm BS COMBINLIST Liệt kê các giá trị tổ hợp, chỉnh hợp, chỉnh hợp không lặp | Add-in A-Tools v10 (2 người xem)
    • Yêu thích
    • Thích
Trả lời
17
Đọc
1K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD
    • Thích
Trả lời
18
Đọc
1K
Hoàng Tuấn 868
H
HeSanbi
  • Đã giải quyết
ZaloExcel v2.95: Gửi tin nhắn, hình ảnh, bảng, biểu đồ, tập tin, tạo nhóm, thu thập tin nhắn
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
60
Đọc
19K
HeSanbi
HeSanbi
J
Xử lý các file Excel bị nặng sau nhiều năm sử dụng (1 người xem)
Trả lời
12
Đọc
2K
lưu tuấn dũng
L
hongphuong1997
Nên sử dụng Chatgpt hay Copilot (1 người xem)
    • Yêu thích
Trả lời
11
Đọc
245
befaint
befaint
D
XIN HỖ TRỢ VỀ FILE EXCEL TỔNG HỢP ĐIỂM THI ĐUA (1 người xem)
Trả lời
0
Đọc
38
DươngH193
D
L
Xin file lịch báo giảng tự động (2 người xem)
Trả lời
2
Đọc
94
linedraw84
L
H
Xin File Theo dõi công nợ
Trả lời
0
Đọc
68
HangktGTN
H
N
Tạo file Excel dùng VBA để lấy và nối dữ liệu từ các files excel
Trả lời
39
Đọc
6K
hungnv_thct2026
H
S
Power BI. Một quá trình đòi hỏi sự kiên nhẫn.
Trả lời
4
Đọc
216
SteveNguyen1991
S
SA_DQ
  • Question Question
Bài tập VBA cho những người rỗi. . . đủ thứ!
    • Ngạc nhiên
    • Cười
    • Yêu thích
Trả lời
21
Đọc
763
Phuocam
Phuocam
H
  • Question Question
Dò tìm giá trị từ bảng khác theo cột
Trả lời
5
Đọc
121
ptm0412
ptm0412
L
Cách bật/tắt đèn led thứ 3 trên bàn phím cơ
Trả lời
1
Đọc
75
HUONGHCKT
H
C
Không thể group cột trong excel
Trả lời
10
Đọc
12K
ptm0412
ptm0412
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn
Trả lời
14
Đọc
1K
Hoàng Tuấn 868
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom