Tạo macro tìm kiếm và thay thế giá trị (1 người xem)

[tb07]

Em có 1 file excel muốn mọi người chỉ giúp em tạo một macro để giảm bớt thao tác thủ công. Chi tiết như file đính kèm.
em cảm ơn nhiều!!!

 

[viehoai]

Em có 1 file excel muốn mọi người chỉ giúp em tạo một macro để giảm bớt thao tác thủ công. Chi tiết như file đính kèm.
em cảm ơn nhiều!!!

Bạn thử code này cho sheet NHAP thử xem nhé
[GPECODE=vb]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, MyRng As Range
If Not Intersect(Range("B2:B1000"), Target) Is Nothing Then
Set MyRng = Sheet2.Range("B1:B" & Sheet2.[B65500].End(3).Row)
Set Rng = MyRng.Find(Target.Value, , , xlValue)
If Not Rng Is Nothing Then
Target.Offset(, 3).Value = Rng.Value
Rng.Font.ColorIndex = 3
End If
Set MyRng = Nothing
Set Rng = Nothing
End If
End Sub[/GPECODE]

 

[ndu96081631]

Em có 1 file excel muốn mọi người chỉ giúp em tạo một macro để giảm bớt thao tác thủ công. Chi tiết như file đính kèm.
em cảm ơn nhiều!!!

Cái này làm bằng tay cũng nhanh. Tôi dùng Advanced Filter như sau:
[video=youtube;LGX6ozC4ZxY]https://www.youtube.com/watch?v=LGX6ozC4ZxY&feature=youtu.be[/video]

 

[tb07]

Bạn thử code này cho sheet NHAP thử xem nhé
[GPECODE=vb]
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, MyRng As Range
If Not Intersect(Range("B2:B1000"), Target) Is Nothing Then
Set MyRng = Sheet2.Range("B1:B" & Sheet2.[B65500].End(3).Row)
Set Rng = MyRng.Find(Target.Value, , , xlValue)
If Not Rng Is Nothing Then
Target.Offset(, 3).Value = Rng.Value
Rng.Font.ColorIndex = 3
End If
Set MyRng = Nothing
Set Rng = Nothing
End If
End Sub[/GPECODE]

Em cảm ơn, nhưng đoạn mã trên em chạy không được. em muốn khi mình nhập xong quét trọn toàn bộ và chạy macro
thì tất cả dữ liệu nhập được thay thế tức thì và bên sheet " theodoi" những giá trị có được đánh dấu.

 

[tb07]

Cái này làm bằng tay cũng nhanh. Tôi dùng Advanced Filter như sau:
[video=youtube;LGX6ozC4ZxY]https://www.youtube.com/watch?v=LGX6ozC4ZxY&feature=youtu.be[/video]

em cảm ơn thầy, thầy xem chỉ dẫn giúp em để tạo một macro có phím tắt
khi em chọn toàn bộ giá trị nhập và chạy macro thì các giá trị trong cột được thay thế và bên sheet"THEODOI"các giá trị cần tìm được đánh dấu.

 

[viehoai]

Em cảm ơn, nhưng đoạn mã trên em chạy không được. em muốn khi mình nhập xong quét trọn toàn bộ và chạy macro
thì tất cả dữ liệu nhập được thay thế tức thì và bên sheet " theodoi" những giá trị có được đánh dấu.

Không được là thế nào ? lỗi gì hay chạy không đúng
Chạy thử code nay xem sao
[GPECODE=vb]Sub GPE()Dim Rng As Range, MyRng As Range, Cll As Range
Application.ScreenUpdating = False
Set MyRng = Sheet2.Range("B1:B" & Sheet2.[B65500].End(3).Row)
For Each Cll In Sheet1.Range("B1:B" & Sheet1.[B65500].End(3).Row)
Set Rng = MyRng.Find(Cll.Value, , , xlValue)
If Not Rng Is Nothing Then
Cll.Offset(, 3).Value = Rng.Value
Rng.Font.ColorIndex = 3
End If
Next
Set MyRng = Nothing
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub[/GPECODE]

 

[tb07]

Không được là thế nào ? lỗi gì hay chạy không đúng
Chạy thử code nay xem sao
[GPECODE=vb]Sub GPE()Dim Rng As Range, MyRng As Range, Cll As Range
Application.ScreenUpdating = False
Set MyRng = Sheet2.Range("B1:B" & Sheet2.[B65500].End(3).Row)
For Each Cll In Sheet1.Range("B1:B" & Sheet1.[B65500].End(3).Row)
Set Rng = MyRng.Find(Cll.Value, , , xlValue)
If Not Rng Is Nothing Then
Cll.Offset(, 3).Value = Rng.Value
Rng.Font.ColorIndex = 3
End If
Next
Set MyRng = Nothing
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub[/GPECODE]

em chạy bị lỗi này , anh xem khắc phục cho em

 

[viehoai]

em chạy bị lỗi này , anh xem khắc phục cho em

Mình copy vào file bạn có lỗi gì đâu

 

[Quang_Hải]

Viết thế này mới ác chiến nè, khỏi khai báo gì ráo.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect([B:B], Target) Is Nothing Then
   With Sheet2.[B:B].Find(Target.Value, , , 2)
      Target.Offset(, 3).Value = .Value
      .Font.ColorIndex = 3
   End With
End If
End Sub

 

[tb07]

ok anh, em đã khắc phục được lỗi, nhưng ý em muốn các giá trị được thay ngay trên cái cột List .anh xem phải sửa code thế nào anh.

 

[tb07]

Viết thế này mới ác chiến nè, khỏi khai báo gì ráo.

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect([B:B], Target) Is Nothing Then
   With Sheet2.[B:B].Find(Target.Value, , , 2)
      Target.Offset(, 3).Value = .Value
      .Font.ColorIndex = 3
   End With
End If
End Sub

em cảm ơn bác, phiền bác có thể giải thích giúp em đoạn code trên không ạ và em sẽ áp dụng như thế nào với bài này các giá trị thay thế ngay các giá trị tìm kiếm ở trong cùng 1 cột List.

 

[Quang_Hải]

em cảm ơn bác, phiền bác có thể giải thích giúp em đoạn code trên không ạ và em sẽ áp dụng như thế nào với bài này các giá trị thay thế ngay các giá trị tìm kiếm ở trong cùng 1 cột List.

Thì thay thử mấy số 3 coi nó ra cái gì

 

[tb07]

Thì thay thử mấy số 3 coi nó ra cái gì

OK, cảm ơn anh, sao em gắn phím tắt thì nó lại không chạy nhỉ anh. và bây giờ e muốn áp dụng bất kỳ ô nào trong sheet đó thì phải làm sao ạ.
mong anh chỉ giúp.

 

[Quang_Hải]

OK, cảm ơn anh, sao em gắn phím tắt thì nó lại không chạy nhỉ anh

Macro sự kiện thì làm sao gán phím tắt chứ. >>> Không được. Bỏ qua suy nghĩ này nha

...và bây giờ e muốn áp dụng bất kỳ ô nào trong sheet đó thì phải làm sao ạ.
mong anh chỉ giúp.

Muốn ô nào, vùng nào thì phải rõ ràng, chứ nếu không code nó chạy loạn 12 sứ quân.

 

[TrungChinhs]

Em có 1 file excel muốn mọi người chỉ giúp em tạo một macro để giảm bớt thao tác thủ công. Chi tiết như file đính kèm.
em cảm ơn nhiều!!!

Bạn thử code này. Trong file đính kèm Bạn có thể dùng phím tắt Ctrl + Shift + R hoặc đúp chuột để chạy code.

Sub Replace()
    On Error Resume Next
    tmp = 0
    tmp = Sheets("TheoDoi").[b:b].Find(Selection, , , 2)
    If tmp > 0 Then Selection = tmp
End Sub

 

[tb07]

anh quanghai1969 à em muốn không phân biệt vùng nào cả chỉ cần khi quét chọn các đối tượng và chạy macro thì sẽ copy các đối tượng tìm thấy ở sheet bên cạnh và thay thế nó .với những giá trị không tìm thấy ở sheet bên cạnh thì vẫn giữ nguyên còn các giá trị tìm thấy được đánh dấu. anh xem có thể tạo một code như vậy không.
Em cảm ơn!

 

[tb07]

Bạn thử code này. Trong file đính kèm Bạn có thể dùng phím tắt Ctrl + Shift + R hoặc đúp chuột để chạy code.

Sub Replace()
    On Error Resume Next
    tmp = 0
    tmp = Sheets("TheoDoi").[b:b].Find(Selection, , , 2)
    If tmp > 0 Then Selection = tmp
End Sub

em cảm ơn anh, code này chạy cho 1 đối tượng thì ok nhưng khi quét trọn toàn bộ thì không được. và vùng tìm kiếm cũng không được đánh dấu.anh xem có thể sửa code này như thế nào để khi ta quét chọn bất kì thì nó sẽ trả lại giá trị đúng, với những giá trị không có thì giữ nguyên.

 

[Quang_Hải]

em cảm ơn anh, code này chạy cho 1 đối tượng thì ok nhưng khi quét trọn toàn bộ thì không được. và vùng tìm kiếm cũng không được đánh dấu.anh xem có thể sửa code này như thế nào để khi ta quét chọn bất kì thì nó sẽ trả lại giá trị đúng, với những giá trị không có thì giữ nguyên.

Sub FindAndGet()
Dim data(), i, Res(), Rng As Range
If Selection.Count = 1 Then Exit Sub
data = Selection.Value
ReDim Res(1 To UBound(data), 1 To 1)
For i = 1 To UBound(data)
   Set Rng = Sheet2.[B:B].Find(data(i, 1), , , 2)
   If Not Rng Is Nothing Then
      Res(i, 1) = Rng.Value
      Rng.Font.ColorIndex = 3
   End If
Next
[E2].Resize(i - 1) = Res
End Sub

 

[TrungChinhs]

em muốn không phân biệt vùng nào cả chỉ cần khi quét chọn các đối tượng và chạy macro thì sẽ copy các đối tượng tìm thấy ở sheet bên cạnh và thay thế nó .với những giá trị không tìm thấy ở sheet bên cạnh thì vẫn giữ nguyên còn các giá trị tìm thấy được đánh dấu. anh xem có thể tạo một code như vậy không.
Em cảm ơn!

Bạn thử code này xem đã đúng ý chưa

Sub Replace()
    On Error Resume Next
    With Sheets("TheoDoi")
       For Each cls In Selection
            tmp = 0
            tmp = .[b:b].Find(cls, , , 2).Address
            If tmp > 0 Then
                .Range(tmp).Font.ColorIndex = 3     'Danh dau tim thay
                cls.Value = .Range(tmp)             'lay gia tri cua sheet ben canh
            End If
       Next
    End With
End Sub

 

[tb07]

các anh thật nhiệt tình , em hỏi một chút nếu vùng tìm kiếm ở một file excel khác và tìm kiếm trên toàn bộ sheet thì code trên sẽ sửa như thế nào:
vd em áp dụng vùng tìm kiếm là 1 sheet ten là "d1" file excel tên là "danhsach".

 

[Quang_Hải]

các anh thật nhiệt tình , em hỏi một chút nếu vùng tìm kiếm ở một file excel khác và tìm kiếm trên toàn bộ sheet thì code trên sẽ sửa như thế nào:
vd em áp dụng vùng tìm kiếm là 1 sheet ten là "d1" file excel tên là "danhsach".

Đại khái thế này. Đuôi file phải đúng với file thật, file này phải đang mở

Sub FindAndGet()
Dim data(), i, Res(), Rng As Range, Nguon As Range
Set Nguon = Workbooks("danhsach.xls").Sheets("d1")
If Selection.Count = 1 Then Exit Sub
data = Selection.Value
ReDim Res(1 To UBound(data), 1 To 1)
For i = 1 To UBound(data)
   Set Rng = Nguon.[B:B].Find(data(i, 1), , , 2)
   If Not Rng Is Nothing Then
      Res(i, 1) = Rng.Value
      Rng.Font.ColorIndex = 3
   End If
Next
[E2].Resize(i - 1) = Res
End Sub