Giúp sửa code: Fương thức Find để nó không Paste lên dữ liệu cũ!

Chia sẻ bởi:hands

★★★★★

‹ Hỏi: Chuyển đổi chữ thành ký tự! Giúp sửa code: Tô màu Font Color... ›

Quảng cáo

Em chào Thầy cô & anh chị!
Em viết code như sau:
Tại Sheet TH, lấy tên khách hàng ở cột G, Tìm tại Cột BE của Sheet MA, nếu tìm được thì lấy qua một cột (Cột BF) và gán nó vào Cột AG của Sheet TH tại dòng tương ứng.

Ví dụ: Tại dòng thứ 9 của Sheet TH, Cell G9 không có Tên khách hàng, Cell AG9 đã có sẵn Mã KH, khi chạy code nó làm mất Mã KH tại cell AG9!!!. Em muốn sửa code, nếu KHÔNG CÓ TÊN KHÁCH HÀNG TẠI CỘT G THÌ KHÔNG ĐƯỢC XÓA MÃ KH ĐÃ CÓ TẠI CỘT AG
Xin xem chi tiết trong File
Code của em

Sub TimMaKH()
Dim i As Long
Dim arrRes, arrSrc
Dim n1 As Range, rTmp As Range
With ActiveSheet
arrSrc = .Range(., ..End(3)).Resize(, 27).Value
End With
With Sheets("MA")
Set n1 = .Range(., ..End(3))
End With
ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 1)
For i = 1 To UBound(arrSrc, 1)
Set rTmp = n1.Find(arrSrc(i, 1), , xlValues, xlWhole)
If Not rTmp Is Nothing Then
'If arrSrc(i, 1) <> "" Then
arrRes(i, 1) = rTmp.Offset(, 1)
'End If
End If
Next i
ActiveSheet.Range("AG9").Resize(UBound(arrRes, 1)).Value = arrRes
End Sub

Em xin cảm ơn!
———–
Em thấy code trên, nếu Sheet TH dữ liệu nhiều thì chạy chậm, Có thể giúp em cải tiến code

Thử với code này xem, hổng biết dữ liệu nhiều nó chạy bao lâu.
Public Sub GPE()
Dim Rng As Range, Cll As Range, Arr(), Dic As Object, I As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Ma")
Arr = .Range(., ..End(xlUp)).Resize(, 2).Value
End With
For I = 1 To UBound(Arr, 1)
If Not Dic.Exists(Arr(I, 1)) Then Dic.Add Arr(I, 1), Arr(I, 2)
Next I
With Sheets("TH")
Set Rng = .Range(., ..End(xlUp))
For Each Cll In Rng
If Cll <> "" Then
If Dic.Exists(Cll.Value) Then
Cll.Offset(, 26).Value = Dic.Item(Cll.Value)
End If
End If
Next
End With
Set Dic = Nothing
Set Rng = Nothing
End Sub

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-s%E1%BB%ADa-code-f%C6%B0%C6%A1ng-th%E1%BB%A9c-find-%C4%91%E1%BB%83-n%C3%B3-kh%C3%B4ng-paste-l%C3%AAn-d%E1%BB%AF-li%E1%BB%87u-c%C5%A9.76186/

Đã trót viết rồi cũng mạo muội đưa lên dù chậm hơn bác Bate

Sub gpe()
Dim i As Long, Arr, ArrKH
ArrKH = Sheets("Ma").Range("BE11:BF" & Sheets("ma").Range("BE65536").End(3).Row)
Arr = Sheets("TH").Range("G9:AG" & Sheets("th").Range("G65536").End(3).Row)

With CreateObject("scripting.dictionary")
    For i = 1 To UBound(ArrKH, 1)
        If Not .exists(ArrKH(i, 1)) Then
            .Add ArrKH(i, 1), ArrKH(i, 2)
        End If
    Next
'-----------------------
    For i = 1 To UBound(Arr, 1)
        If Arr(i, 1) <> "" And .exists(Arr(i, 1)) Then
                Arr(i, 27) = .Item(Arr(i, 1))
        End If
    Next
End With
Sheets("TH").[G9].Resize(UBound(Arr, 1), UBound(Arr, 2)) = Arr
End Sub

Code này nếu trong các cột H:AF có tính toán bằng công thức thì … hổng còn công thức nào???

Vâng đúng rồi ạ. Em nhìn cái Form này quen quen, bạn í lần trước cũng đã hỏi về tính xuất, nhập, tồn rồi vậy có thể không dùng công thức(hihi) mà có nhỡ dùng công thức thì đã có Code thấy Ba tê.

Hi, dùng code của anh đỡ fải Paste Value!
Em xin cảm ơn các Thầy & anh đã giúp em!

Xem code nông dân này rồi đem ra cày xem nhé.
Mặc dù cách này chạy chậm hơn dùng Dictionary nhưng sẽ giúp các bạn nắm được căn bản nhanh hơn
Mình nhân bản dữ liệu của bạn lên hơn 6000 dòng và chạy chưa đến 0.5 giây

Sub TimMaKH2()
Dim i As Long, j As Long
Dim ArrDes(), arrSrc(), result()
ArrDes = Range(, .End(3)).Value
result = Range(, .End(3)).Offset(, 26).Value
With Sheets("MA")
arrSrc = .Range(., ..End(3)).Resize(, 2).Value
End With
For i = 1 To UBound(ArrDes, 1)
For j = 1 To UBound(arrSrc)
If ArrDes(i, 1) <> "" Then
If result(i, 1) = "" Then
If ArrDes(i, 1) = arrSrc(j, 1) Then
result(i, 1) = arrSrc(j, 2)
Exit For
End If
End If
End If
Next j
Next i
ActiveSheet.Range("AG9").Resize(i – 1, 1).Value = result
End Sub

Nếu dùng Dic thì xài thêm 1 mảng kết quả nữa để tránh xử lý trên sheet luôn. Nếu lỡ như cột AG có công thức thì mình sẽ dùng .Formula, không dùng .Value nữa…
Chắc bạn nắm vững rồi nhỉ?

Sub TimMaKH3()
Dim I As Long, j As Long, Des(), Src(), Result()
Des = Range(, .End(3)).Value
Result = Range(, .End(3)).Offset(, 26).Value
With Sheets("MA")
Src = .Range(., ..End(3)).Resize(, 2).Value
End With
With CreateObject("scripting.dictionary")
For I = 1 To UBound(Src)
If Not .exists(Src(I, 1)) Then .Add Src(I, 1), Src(I, 2)
Next
For I = 1 To UBound(Des)
If Des(I, 1) <> "" Then
If Result(I, 1) = "" Then
If .exists(Des(I, 1)) Then Result(I, 1) = .Item(Des(I, 1))
End If
End If
Next
End With
ActiveSheet.Range("AG9").Resize(I – 1, 1).Value = Result
End Sub

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-s%E1%BB%ADa-code-f%C6%B0%C6%A1ng-th%E1%BB%A9c-find-%C4%91%E1%BB%83-n%C3%B3-kh%C3%B4ng-paste-l%C3%AAn-d%E1%BB%AF-li%E1%BB%87u-c%C5%A9.76186/post-468070

Anh Hải cho em hỏi
result = Range([AG9], .End(3)).Offset(, 26).Value
Tại sao câu trên như vậy, mà nó không fải như vầy
result = Range([G9], .End(3)).Offset(, 26).Value
Mong anh giải thích , em cảm ơn

Chắc mình viết code sai í mà. Lâu quá rồi nên không nhớ. Nhưng nhìn vào kỳ kỳ sao ấy
Chắc lúc đó ý mình là thế này vì mảng Result chỉ cần có 1 cột.
Result = Range(, .End(3).Offset(, 26)).Value

……………..
Nếu chỉnh lại như HV hỏi thì chắc là chính xác rồi

result = Range([G9], .End(3)).Offset(, 26).Value

www.giaiphapexcel.com/diendan/threads/gi%C3%BAp-s%E1%BB%ADa-code-f%C6%B0%C6%A1ng-th%E1%BB%A9c-find-%C4%91%E1%BB%83-n%C3%B3-kh%C3%B4ng-paste-l%C3%AAn-d%E1%BB%AF-li%E1%BB%87u-c%C5%A9.76186/post-472585

Khóa học SprinGO phù hợp

Khóa học Power PI – Ứng dung trong Nhân sự

TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...

Xem khóa học

★★★★★ 5 ★ 1 👤 1 ▥ 0

‹ Hỏi: Chuyển đổi chữ thành ký tự! Giúp sửa code: Tô màu Font Color theo... ›

Quảng cáo

Bạn nên đọc

One Response

hands says:

20/12/2022 at 4:37 pm

Sub TimMaKH3()
Dim I As Long, j As Long, Des(), Src(), Result()
Des = Range(, .End(3)).Value
Result = Range(, .End(3)).Offset(, 26).Value
With Sheets("MA")
Src = .Range(., ..End(3)).Resize(, 2).Value
End With
With CreateObject("scripting.dictionary")
For I = 1 To UBound(Src)
If Not .exists(Src(I, 1)) Then .Add Src(I, 1), Src(I, 2)
Next
For I = 1 To UBound(Des)
If Des(I, 1) <> "" Then
If Result(I, 1) = "" Then
If .exists(Des(I, 1)) Then Result(I, 1) = .Item(Des(I, 1))
End If
End If
Next
End With
ActiveSheet.Range("AG9").Resize(I – 1, 1).Value = Result
End Sub

cho em hỏi nếu không chỉ hiển thị 1 cột mã khách hàng mà hiển thị cả một range bao gồm cả cột mã, cột tên, cột phụ … đằng sau nữa thì sửa code trên như thế nào ạ.

Mỗi code viết phục vụ cho một mục đích và một kiểu dữ liệu.
Nếu bạn muốn làm khác đi thì nên đưa file có dữ liệu ví dụ lên và nói rõ muốn làm gì với nó.
Bạn hỏi chung chung như vậy thì khó trả lời quá.

àh file của em giống như file trên, em muốn khi nhấn tìm mã thì ngoài cột mã hiển thị tương ứng có thêm tên (gắn liền ngay sau cột mã khách hàng) ngay bên cạnh. Nói chung là tất cả những gì liên quan đến cột mã đều hiển thị luôn.

Vậy bạn dùng hàm Vlookup() là được rồi.
——————————————
Nếu muốn code làm thay cho Vlookup() hàng mấy chục cột phía sau thì thử code này.
Phía sau BF9 trong sheet Ma nếu có tiêu đề là lấy hết
(Nó chỉ sử dụng cho dữ liệu trong file của bạn)
Public Sub MyLook()
Dim Rng(), Arr(), KQ(), I As Long, J As Long, K As Long, Cot As Long, Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Ma")
Cot = .Range(., ..End(xlToLeft)).Columns.Count
Rng = .Range(., ..End(xlUp)).Resize(, Cot).Value
End With
ReDim Arr(1 To UBound(Rng, 1), 1 To Cot)
For I = 1 To UBound(Rng, 1)
Tem = Rng(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
For J = 1 To Cot
Arr(K, J) = Rng(I, J)
Next J
End If
Next I
With Sheets("TH")
Rng = .Range(., ..End(xlUp)).Resize(, Cot).Value
ReDim KQ(1 To UBound(Rng, 1), 1 To Cot)
For I = 1 To UBound(Rng, 1)
Tem = Rng(I, 1)
If Tem <> "" Then
If Dic.Exists(Tem) Then
For J = 1 To Cot
KQ(I, J) = Arr(Dic.Item(Tem), J)
Next J
End If
End If
Next I
..Resize(I – 1, Cot).Value = KQ
End With
Set Dic = Nothing
End Sub
Tôi dựa vào code cua Anh Hải làm thử cho bạn
```
Sub TimMaKH3()
    Dim i As Long, j As Long
    Dim ArrDes(), arrSrc(), result()
    ArrDes = Range([G9], [G65536].End(3)).Value
    result = Range([G9], [G65536].End(3)).Offset(, 26).Resize(, 2).Value
    With Sheets("MA")
        arrSrc = .Range(.[BE10], .[BE10000].End(3)).Resize(, 3).Value
    End With
    For i = 1 To UBound(ArrDes, 1)
        For j = 1 To UBound(arrSrc)
            If ArrDes(i, 1) <> "" Then
                If result(i, 1) = "" Then
                    If ArrDes(i, 1) = arrSrc(j, 1) Then
                        result(i, 1) = arrSrc(j, 2)
                        result(i, 2) = arrSrc(j, 3)
                        Exit For
                    End If
                End If
            End If
        Next j
    Next i
    ActiveSheet.Range("AG9").Resize(i - 1, 2).Value = result
End Sub
```
Cảnh báo nếu cột AG, có cái gì khác ngoài mã tìm được thì nó không xóa!!!
Em cám ơn rất nhiều tuy nhiên:

code của bác Bate nếu xóa cột mã sẵn có thì không chạy (em muốn lấy cả mã khách hàng và các cột bên cạnh mã)
=============================

cột mã | cột tên | cột tháng

M013

=> code chạy chính xác

cột mã

bỏ trống

không có biểu hiện gì thay đổi
==========================================
code của bác Hong.Van thì chạy nhưng bị dính nội dung của các cột

cột mã | cột tên | cột tháng

M013 | nguyen van a1 | 17

code chạy thành

cột mã | cột tên | cột tháng

M013 | nguyen van a117 |

Hóa ra là lookup từ cột G sheet TH. Lấy dữ liệu từ cột BF sheet Ma trở về sau?
Vậy kiểm tra lại code này xem:
Public Sub MyLook()
Dim Rng(), Arr(), KQ(), I As Long, J As Long, K As Long, Cot As Long, Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Ma")
Cot = .Range(., ..End(xlToLeft)).Columns.Count
Rng = .Range(., ..End(xlUp)).Resize(, Cot + 1).Value
End With
ReDim Arr(1 To UBound(Rng, 1), 1 To Cot)
For I = 1 To UBound(Rng, 1)
Tem = Rng(I, 1)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
For J = 2 To Cot + 1
Arr(K, J – 1) = Rng(I, J)
Next J
End If
Next I
With Sheets("TH")
Rng = .Range(., ..End(xlUp)).Value
ReDim KQ(1 To UBound(Rng, 1), 1 To Cot)
For I = 1 To UBound(Rng, 1)
Tem = Rng(I, 1)
If Tem <> "" Then
If Dic.Exists(Tem) Then
For J = 1 To Cot
KQ(I, J) = Arr(Dic.Item(Tem), J)
Next J
End If
End If
Next I
..Resize(I – 1, Cot).Value = KQ
End With
Set Dic = Nothing
End Sub
Bạn xem kỹ chưa vậy M013 thì tên là nguyen van a117 thì đúng rồi !Còn muốn lấy thêm cột tháng bên Sh MA thì fải sửa code 1 chút
```
Sub TimMaKH3()
    Dim i As Long, j As Long
    Dim ArrDes(), arrSrc(), result()
    ArrDes = Range([G9], [G65536].End(3)).Value
    result = Range([G9], [G65536].End(3)).Offset(, 26).Resize(, 3).Value
    With Sheets("MA")
        arrSrc = .Range(.[BE10], .[BE10000].End(3)).Resize(, 4).Value
    End With
    For i = 1 To UBound(ArrDes, 1)
        For j = 1 To UBound(arrSrc)
            If ArrDes(i, 1) <> "" Then
                If result(i, 1) = "" Then
                    If ArrDes(i, 1) = arrSrc(j, 1) Then
                        result(i, 1) = arrSrc(j, 2)
                        result(i, 2) = arrSrc(j, 3)
                        result(i, 3) = arrSrc(j, 4)
                        Exit For
                    End If
                End If
            End If
        Next j
    Next i
    ActiveSheet.Range("AG9").Resize(i - 1, 3).Value = result
End Sub
```
Reply