dò tìm nhiều dữ liệu bằng VBA (1 người xem)

[hoangnam2015]

giúp em viết VBA cho file đính kèm bên dưới. công việc mô tả trong file.

 

[phihndhsp]

giúp em viết VBA cho file đính kèm bên dưới. công việc mô tả trong file.

Chỉ là công thức dò tìm đơn thuần thôi mà, cần chi sử dụng đến VI BI ÂY
B5=VLOOKUP($A5,Sheet1!$A$4:$F$27,COLUMNS($A:B),0)

 

[Let'GâuGâu]

giúp em viết VBA cho file đính kèm bên dưới. công việc mô tả trong file.

góp thêm đoạn code
bạn có thể dùng Find
thử dùng mảng

Sub DoTim()
Dim Nguon, tim As Variant, i, j, k As Long
Nguon = Sheet1.[A4].Resize(Sheet1.[A60000].End(3).Row - 3, 6).Value
tim = Sheet2.[A5].Resize(Sheet2.[A60000].End(3).Row - 3, 6).Value
For i = 1 To UBound(tim)
    For j = i To UBound(Nguon)
        If tim(i, 1) = Nguon(j, 1) Then
            For k = 2 To 6
                tim(i, k) = Nguon(j, k)
            Next
        Exit For
        End If
    Next
Next
Sheet2.[A5:F10000].ClearContents
Sheet2.[A5].Resize(i - 1, 6).Value = tim
End Sub

 

[hoangnam2015]

cảm ơn bạn phihndhsp
nếu dò tìm nhiều quá sẽ tạo cho file nặng và chạy lâu. số lượng dữ liệu lớn có thể nặng. bạn có cách nào viết VBA không? Hàm thì mình biết cách dùng rồi.

 

[hoangnam2015]

góp thêm đoạn code
bạn có thể dùng Find
thử dùng mảng

Sub DoTim()
Dim Nguon, tim As Variant, i, j, k As Long
Nguon = Sheet1.[A4].Resize(Sheet1.[A60000].End(3).Row - 3, 6).Value
tim = Sheet2.[A5].Resize(Sheet2.[A60000].End(3).Row - 3, 6).Value
For i = 1 To UBound(tim)
    For j = i To UBound(Nguon)
        If tim(i, 1) = Nguon(j, 1) Then
            For k = 2 To 6
                tim(i, k) = Nguon(j, k)
            Next
        Exit For
        End If
    Next
Next
Sheet2.[A5:F10000].ClearContents
Sheet2.[A5].Resize(i - 1, 6).Value = tim
End Sub

cảm ơn anh,

em có cái thắc mắc như sau:
1. khi tìm giá trị mới ít hơn thì giá trị cũ không bị xóa
2. khi để trống 1 ô thì giá trị tìm không ra.

 

[HungQuoc49]

giúp em viết VBA cho file đính kèm bên dưới. công việc mô tả trong file.

Thêm một lựa chọn nữa
Dán code này vào sheet "Dò tìm"

Private Sub Worksheet_Change(ByVal Target As Range)
Dim DL, r As Long, rw As Long, c As Long

DL = Sheet1.Range("A3").CurrentRegion
rw = 0

If Target.Column = 1 And Target.Row > 4 Then
For r = 2 To UBound(DL)
If DL(r, 1) = Target.Value Then
rw = r
Exit For
End If
Next r

If rw <> 0 Then
For c = 2 To UBound(DL, 2)
Sheet2.Cells(Target.Row, c).Value = DL(r, c)
Next c
Else
Sheet2.Range(Cells(Target.Row, 2), Cells(Target.Row, UBound(DL, 2))).ClearContents
MsgBox "Khong Co Ten Nay"
End If

End If
End Sub

 

[Let'GâuGâu]

cảm ơn anh,

em có cái thắc mắc như sau:
1. khi tìm giá trị mới ít hơn thì giá trị cũ không bị xóa
2. khi để trống 1 ô thì giá trị tìm không ra.

tôi làm lộn tí...hehehehe.định sửa mà không kịp..khekhe

Sub DoTim()
Dim Nguon, tim As Variant, i, j, k As Long
Nguon = Sheet1.[A4].Resize(Sheet1.[A60000].End(3).Row - 3, 6).Value
tim = Sheet2.[A5].Resize(Sheet2.[A60000].End(3).Row - 4, 6).Value
For i = 1 To UBound(tim)
If Not IsEmpty(tim(i, 1)) Then
    For j = 1 To UBound(Nguon)
        If tim(i, 1) = Nguon(j, 1) Then
            For k = 2 To 6
                tim(i, k) = Nguon(j, k)
            Next
        Exit For
        End If
    Next
End If
Next
Sheet2.[A5:F10000].ClearContents
Sheet2.[A5].Resize(i - 1, 6).Value = tim
End Sub

 

[hoangnam2015]

Đã ra rồi. cảm ơn bài của HungQuoc49 và Let'GâuGâu

 

[giola]

Đã ra rồi. cảm ơn bài của HungQuoc49 và Let'GâuGâu

Thận trọng với post#7 (code sau), vì sử dụng lại tim, nên nếu sau khi chạy lần 1, giờ hiệu chỉnh, xoá nội dung 1 cell nào đó thuộc cột A -- kết quả sẽ sai vì vẫn lưu kết quả cũ, hoặc nhập một giá trị không tìm thấy (ví dụ AAA) thì kết quả vẫn như cũ

tôi làm lộn tí...hehehehe.định sửa mà không kịp..khekhe

Sub DoTim()
Dim Nguon, tim As Variant, i, j, k As Long
Nguon = Sheet1.[A4].Resize(Sheet1.[A60000].End(3).Row - 3, 6).Value
tim = Sheet2.[A5].Resize(Sheet2.[A60000].End(3).Row - 4, 6).Value
For i = 1 To UBound(tim)
If Not IsEmpty(tim(i, 1)) Then
    For j = 1 To UBound(Nguon)
        If tim(i, 1) = Nguon(j, 1) Then
            For k = 2 To 6
                tim(i, k) = Nguon(j, k)
            Next
        Exit For
        End If
    Next
End If
Next
Sheet2.[A5:F10000].ClearContents
Sheet2.[A5].Resize(i - 1, 6).Value = tim
End Sub

Tôi chưa kiểm tra (test) kỹ , bạn tự thử kiểm tra lại

 

[Let'GâuGâu]

Thận trọng với post#7 (code sau), vì sử dụng lại tim, nên nếu sau khi chạy lần 1, giờ hiệu chỉnh, xoá nội dung 1 cell nào đó thuộc cột A -- kết quả sẽ sai vì vẫn lưu kết quả cũ, hoặc nhập một giá trị không tìm thấy (ví dụ AAA) thì kết quả vẫn như cũ



Tôi chưa kiểm tra (test) kỹ , bạn tự thử kiểm tra lại

à đúng rồi, bài này dạng tìm một lần
nếu muốn tìm nhiều lần thì phải xóa vùng dữ liệu đi hoặc tạo một mảng kết qua...........chắc là vậy heheheh

Sub DoTim()
Dim Nguon, tim As Variant, i, j, k As Long
Nguon = Sheet1.[A4].Resize(Sheet1.[A60000].End(3).Row - 3, 6).Value
With Sheet2
    .[B5:F10000].ClearContents
    tim = .[A5].Resize(.[A60000].End(3).Row - 4, 6).Value
End With
For i = 1 To UBound(tim)
If Not IsEmpty(tim(i, 1)) Then
    For j = 1 To UBound(Nguon)
        If tim(i, 1) = Nguon(j, 1) Then
            For k = 2 To 6
                tim(i, k) = Nguon(j, k)
            Next
        Exit For
        End If
    Next
End If
Next
Sheet2.[A5:F10000].ClearContents
Sheet2.[A5].Resize(i - 1, 6).Value = tim
End Sub

 

[giola]

Thận trọng với post#7 (code sau), vì sử dụng lại tim, nên nếu sau khi chạy lần 1, giờ hiệu chỉnh, xoá nội dung 1 cell nào đó thuộc cột A -- kết quả sẽ sai vì vẫn lưu kết quả cũ, hoặc nhập một giá trị không tìm thấy (ví dụ AAA) thì kết quả vẫn như cũ

Giải pháp tạm khắc phục như sau

Sub FindLUA()
    Dim sAr As Variant, fAr As Variant, rAr As Variant
    Dim i As Long, j  As Long, k As Long, ns As Long, nf As Long
    
    With Sheet1.[A4]:   sAr = .Resize(.Offset(60000).End(xlUp).Row - .Row + 1, 6).Value:    End With
    With Sheet2.[A5]:   fAr = .Resize(.Offset(60000).End(xlUp).Row - .Row + 1).Value:       End With
    ns = UBound(sAr)
    nf = UBound(fAr)
    ReDim rAr(1 To nf, 1 To 5)
    
    For i = 1 To nf
        If fAr(i, 1) <> "" Then
            For j = 1 To ns
                If fAr(i, 1) = sAr(j, 1) Then
                    For k = 2 To 6
                        rAr(i, k - 1) = sAr(j, k)
                    Next
                    Exit For
                End If
            Next
        End If
    Next
    
    With Sheet2.[B5]
        .Resize(10000, 5).ClearContents
        .Resize(nf, 5).Value = rAr
    End With
End Sub