Sư kiện worksheet_Change.

overnight_9 · 14/8/12

dears Các anh chị,
xin chỉ em đoạn code worksheet_change.

Nếu trong sheet1 cột A, có các chữ viết tắt ở cột A
mình dùng sự kiện change để thay đổi các chữ viết tắt này thành chữ có nghĩa. và xoá (delete) nguyên dòng của cell đó nếu chữ không có nghĩa.
VD:
cell (A2): viết tắt là "ST" change "Suoi Tien"
cell (A3): viết tắt là "TP" change "Thanh Pho";
...v...v....
cell (A10): viết tắt là "TB" thì tự động xoá (delete) nguyên dòng A10 này luôn.

cell (A11): viết tắt là "Khongconghia" thì tự động xoá (delete) nguyên dòng A11 này luôn.

còn ngoài những từ được thiết lập này các từ khác không thay đổi.

anh chị cho em xin 1 đoạn code em cảm ơn.

ndu96081631 · 14/8/12

overnight_9 đã viết:
dears Các anh chị,
xin chỉ em đoạn code worksheet_change.

Nếu trong sheet1 cột A, có các chữ viết tắt ở cột A
mình dùng sự kiện change để thay đổi các chữ viết tắt này thành chữ có nghĩa. và xoá (delete) nguyên dòng của cell đó nếu chữ không có nghĩa.
VD:
cell (A2): viết tắt là "ST" change "Suoi Tien"
cell (A3): viết tắt là "TP" change "Thanh Pho";
...v...v....
cell (A10): viết tắt là "TB" thì tự động xoá (delete) nguyên dòng A10 này luôn.

cell (A11): viết tắt là "Khongconghia" thì tự động xoá (delete) nguyên dòng A11 này luôn.

còn ngoài những từ được thiết lập này các từ khác không thay đổi.

anh chị cho em xin 1 đoạn code em cảm ơn.

Có thể làm được nhưng bạn phải đưa lên đây 1 bảng tra cứu các từ viết tắt + change ấy rồi ta sẽ bàn tiếp
Ngoài ra bạn phải làm rõ vụ xóa dòng nghĩa là xóa nguyên dòng hay chỉ xóa giá trị trong dòng ấy?

overnight_9 · 14/8/12

ndu96081631 đã viết:
Có thể làm được nhưng bạn phải đưa lên đây 1 bảng tra cứu các từ viết tắt + change ấy rồi ta sẽ bàn tiếp
Ngoài ra bạn phải làm rõ vụ xóa dòng nghĩa là xóa nguyên dòng hay chỉ xóa giá trị trong dòng ấy?

Thầy NDU làm giúp em vài từ, rồi em sẽ add thêm vào code.

Xoá là xoá luôn dòng đó thầy NDU ơi.

em cảm ơn.

ndu96081631 · 14/8/12

overnight_9 đã viết:
Thầy NDU làm giúp em vài từ, rồi em sẽ add thêm vào code.

Xoá là xoá luôn dòng đó thầy NDU ơi.

em cảm ơn.

Thử vầy xem
1> Cho code dưới đây vào 1 module

Mã:

Public Dic As Object
Sub Auto_Open()
  Dim Arr1, Arr2, i As Long
  On Error Resume Next
  [COLOR=#ff0000]Arr1 = Array("ST", "TP", "TC")[/COLOR]
  [COLOR=#ff0000]Arr2 = Array("Suoi Tien", "Thanh Pho", "Tong Cong")[/COLOR]
  If Dic Is Nothing Then Set Dic = CreateObject("Scripting.Dictionary")
  For i = 0 To UBound(Arr1)
    Dic.Add Arr1(i), Arr2(i)
  Next
End Sub

2> Cho code dưới đây vào sheet1

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Rng As Range, lR As Long, tmp As String
  On Error Resume Next
  Application.EnableEvents = False
  If Not Intersect(Range("A1:A10"), Target) Is Nothing Then
    If Dic Is Nothing Then
      Set Dic = CreateObject("Scripting.Dictionary")
      Auto_Open
    End If
    Set Rng = Intersect(Range("A1:A10"), Target)
    For lR = Rng.Rows.Count To 1 Step -1
      tmp = Rng(lR, 1).Value
      If Dic.Exists(tmp) Then
        Rng(lR, 2).Value = Dic.Item(tmp)
      Else
        Rng(lR).EntireRow.Delete
      End If
    Next
  End If
  Application.EnableEvents = True
End Sub

Chú ý chổ màu đỏ, đấy là "thư viện" mà bạn có thể thêm bớt tùy ý
Chạy thử, có gì trục trặc ta bàn tiếp nhé

ptm0412 · 14/8/12

Sao không làm thế này, không cần Dic:

Viết chay nha:

PHP:

Sub Chay()
Application.ScreenUpdating = False
    Arr1 = Array("ST", "TP", "TC")
    Arr2 = Array("Suoi Tien", "Thanh Pho", "Tong Cong")
    MyStr = Join(Arr1, "")
    For j = 100 To 1 Step -1
        If InStr(1, MyStr, Cells(j, 1).Value) > 0 Then
            For i = 0 To UBound(Arr1)
                Cells(j, 1).Replace Arr1(i), Arr2(i)
            Next i
        Else
            Cells(j, 1).EntireRow.Delete
        End If
    Next
Application.ScreenUpdating = True
End Sub

ndu96081631 · 15/8/12

ptm0412 đã viết:

Sao không làm thế này, không cần Dic:

Viết chay nha:

PHP:

Sub Chay()
Application.ScreenUpdating = False
    Arr1 = Array("ST", "TP", "TC")
    Arr2 = Array("Suoi Tien", "Thanh Pho", "Tong Cong")
    MyStr = Join(Arr1, "")
    For j = 100 To 1 Step -1
        If InStr(1, MyStr, Cells(j, 1).Value) > 0 Then
            For i = 0 To UBound(Arr1)
                Cells(j, 1).Replace Arr1(i), Arr2(i)
            Next i
        Else
            Cells(j, 1).EntireRow.Delete
        End If
    Next
Application.ScreenUpdating = True
End Sub

Nhưng người ta muốn dùng sự kiện Change mà sư phụ... tức gõ đúng từ khóa thì điền thêm nghĩa bên cạnh, gõ sai xóa luôn

ptm0412 · 15/8/12

Ở đây mình cho rằng tác giả nhầm ý nghĩa sự kiện change và ứng dụng của sự kiện change:
- Nếu gõ sai từ khóa thì xóa dòng
- Nếu gõ đúng từ viết tắt, thì tự thay từ viết tắt thành từ đầy đủ.

Nghĩa là chỉ xử lý trên target là 1 cell trong cột A

Trong khi đó tác giả muốn thay thế hoặc xóa hàng loạt dòng có sẵn, tham số target không nói đến trong đề bài. Có thể tác giả có sẵn bảng dữ liệu, cũng có thể tác giả copy dữ liệu hàng loạt từ nơi khác đến, và muốn xử 1 lần cho nhiều dòng.

Xử 1 lần nhiều dòng thì dùng sub, không dùng sự kiện change, vì cứ mỗi khi đụng chạm đến bảng tính là phải dò hàng trăm, hàng ngàn dòng để thực hiện, có khi chả có gì để thực hiện vì đã thực hiện xong từ lần chạy đầu tiên rồi.

overnight_9 · 15/8/12

ptm0412 đã viết:
Ở đây mình cho rằng tác giả nhầm ý nghĩa sự kiện change và ứng dụng của sự kiện change:
- Nếu gõ sai từ khóa thì xóa dòng
- Nếu gõ đúng từ viết tắt, thì tự thay từ viết tắt thành từ đầy đủ.
..................

cám ơn thầy My,
Thầy nói đúng ý em muốn diễn đạt, ngồi nghĩ mãi mà không biết diễn đạt sao cho hết ý mình cần.

rong khi đó tác giả muốn thay thế hoặc xóa hàng loạt dòng có sẵn, tham số target không nói đến trong đề bài. Có thể tác giả có sẵn bảng dữ liệu, cũng có thể tác giả copy dữ liệu hàng loạt từ nơi khác đến, và muốn xử 1 lần cho nhiều dòng.

Đúng cho trương hợp của em đang làm vậy mình phải làm 1 sub, sẽ mặc định cột để xử lý là: A or B or C, em gọi sub ra sữ lý 1 lần, còn thư viện (những từ viết tắt = câu có nghĩa, những từ không nghĩa sẽ automatic xoá đi) nên em phải được cập nhật thường xuyên. vậy các thầy cho em 1 đoạn code này em cám ơn các thầy.

Cho em giải thích 1 chút: như em có trình bài với thầy NDU, là những cái em đang xử lý là để chạy theo những cái họ không hiểu, trong đầu họ nghĩ là CNTT sẽ xử lý mấy cái họ đang làm. em chưa đủ trình độ để nói họ hiểu mà cải thiện đống rác này bây giờ, phải có thời gian cho việc đó.

ptm0412 · 15/8/12

Sub thì bài trên đã có 1 sub rồi đấy?

Tuy nhiên nó chưa tối ưu vì tôi đang muốn giới thiệu thuật toán replace trong vòng lặp.
- Có thể hạn chế số lần lặp, hoặc bỏ vòng lặp
- Có thể tạo "thư viện" trong sheet, và đặt name động để có thể cập nhật dễ dàng, và có thể dùng Unicode

overnight_9 · 15/8/12

ptm0412 đã viết:

Sao không làm thế này, không cần Dic:

Viết chay nha:

PHP:

Sub Chay()
Application.ScreenUpdating = False
    Arr1 = Array("ST", "TP", "TC")
    Arr2 = Array("Suoi Tien", "Thanh Pho", "Tong Cong")
    MyStr = Join(Arr1, "")
    For j = 100 To 1 Step -1
        If InStr(1, MyStr, Cells(j, 1).Value) > 0 Then
            For i = 0 To UBound(Arr1)
                Cells(j, 1).Replace Arr1(i), Arr2(i)
            Next i
        Else
            Cells(j, 1).EntireRow.Delete
        End If
    Next
Application.ScreenUpdating = True
End Sub

dears thầy NDU & thầy My
em có gởi lại file trong file là ý em muốn thực hiện.
Chỉ dò tìm những từ có trong thư viện để thay đổi or xoá thôi, nếu trong thư viện không có thì giữ nguyên các dữ liệu khác trong sheet.

cám ơn các thầy.

concogia · 15/8/12

overnight_9 đã viết:
dears thầy NDU & thầy My
em có gởi lại file trong file là ý em muốn thực hiện.
Chỉ dò tìm những từ có trong thư viện để thay đổi or xoá thôi, nếu trong thư viện không có thì giữ nguyên các dữ liệu khác trong sheet.

cám ơn các thầy.

Cái này đơn giản thôi mà em trai, dùng "Đít- to"

Mã:

Public Sub ThayThe()
    Dim d, Vung, VungThay, I, J
    Set d = CreateObject("scripting.dictionary")
    Set VungThay = Range([B9], [B10000].End(xlUp)).Resize(, 2)
    Vung = Sheets("thu vien").Range(Sheets("thu vien").[A4], Sheets("thu vien").[A10000].End(xlUp)).Resize(, 2)
        For I = 1 To UBound(Vung)
            If Not d.exists(Vung(I, 1)) Then d.Add Vung(I, 1), Vung(I, 2)
        Next I
            For I = VungThay.Rows.Count To 1 Step -1
                For J = 1 To 2
                    If d.exists(VungThay(I, J).Value) Then
                        If d.Item(VungThay(I, J).Value) <> "" Then
                            VungThay(I, J) = d.Item(VungThay(I, J).Value)
                        Else
                            VungThay(I, J).EntireRow.Delete
                        End If
                    End If
                Next J
            Next I
End Sub

Không dùng "Đít- to"

Mã:

Public Sub Thay()
    Dim Vung, VungThay, I, J, Gom
    Set Vung = Sheets("thu vien").Range(Sheets("thu vien").[A4], Sheets("thu vien").[A10000].End(xlUp))
    Set VungThay = Range([B9], [B10000].End(xlUp))
    Gom = Join(Application.WorksheetFunction.Transpose(Vung), " ")
        For I = VungThay.Rows.Count To 1 Step -1
            If InStr(1, Gom, VungThay(I)) Then
                J = Application.WorksheetFunction.Match(VungThay(I), Vung, 0)
                    If Vung.Offset(, 1)(J) <> "" Then
                        VungThay(I) = Vung.Offset(, 1)(J)
                    Else
                        VungThay(I).EntireRow.Delete
                    End If
            End If
        Next I
End Sub

Thân

overnight_9 · 15/8/12

Em cám ơn thầy Co nhiều!

overnight_9 · 20/8/12

kg: thầy Co & anh QuangHai.
Nếu sữ dụng Code của sư kiện change để thay thế công thức VLOOKUP cho 1 cột như thế nào, cho em xin 1 đoạn code đi. em cám ơn

Ba Tê · 20/8/12

overnight_9 đã viết:
kg: thầy Co & anh QuangHai.
Nếu sữ dụng Code của sư kiện change để thay thế công thức VLOOKUP cho 1 cột như thế nào, cho em xin 1 đoạn code đi. em cám ơn

Thử với đoạn code này cho sheet "KQ" xem.

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng(), I As Long, Cll As Range
    Rng = Sheets("TV").Range(Sheets("TV").[A5], Sheets("TV").[B65000].End(xlUp)).Value
If Not Intersect(Target, [C5:C10000]) Is Nothing Then
    For Each Cll In Target
        If Cll.Value <> "" Then
            For I = 1 To UBound(Rng, 1)
                If Rng(I, 1) = Cll.Value Then
                    Cll.Offset(, -1).Value = Rng(I, 2)
                    Exit For
                End If
            Next I
        Else
            Cll.Offset(, -1) = ""
        End If
    Next
End If
End Sub

Quang_Hải · 20/8/12

overnight_9 đã viết:
kg: thầy Co & anh QuangHai.
Nếu sữ dụng Code của sư kiện change để thay thế công thức VLOOKUP cho 1 cột như thế nào, cho em xin 1 đoạn code đi. em cám ơn

Đoạn code này là chèn công thức vào giống như mình làm thủ công

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 3 And Target <> "" Then
  Target.Offset(, -1).Formula = "=VLOOKUP(RC[1],TV!R5C1:R58C2,2,0)"
End If
End Sub

Nếu muốn ra giá trị thì đoạn code này tương đối gọn

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 3 And Target <> "" Then
  Target.Offset(, -1) = Sheet1.[a5:a58].Find(Target, , , xlWhole).Offset(, 1)
End If
End Sub

overnight_9 · 20/8/12

Ba Tê đã viết:

Thử với đoạn code này cho sheet "KQ" xem.

PHP:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng(), I As Long, Cll As Range
    Rng = Sheets("TV").Range(Sheets("TV").[A5], Sheets("TV").[B65000].End(xlUp)).Value
If Not Intersect(Target, [C5:C10000]) Is Nothing Then
    For Each Cll In Target
        If Cll.Value <> "" Then
            For I = 1 To UBound(Rng, 1)
                If Rng(I, 1) = Cll.Value Then
                    Cll.Offset(, -1).Value = Rng(I, 2)
                    Exit For
                End If
            Next I
        Else
            Cll.Offset(, -1) = ""
        End If
    Next
End If
End Sub

kg: Thầy Bate,
Cám ơn thầy nhiều em có thêm 1 sub nưa là:

PHP:

Private Sub CommandButton1_Click()
Range("A5:C65000").ClearContents
Range("A5:C65000").Interior.ColorIndex = 0
End Sub

kích hoạt sub này thì sư kiên change lỗi biên

Else
Cll.Offset(, -1) = ""

nhưng em dùng bàn phím delete thì không bị lỗi, vậy khắc phục thế nào vây thầy?

overnight_9 · 20/8/12

Em dùng On Error Resume Next có được không anh Quanghai?

em đưa vào thấy chay im ru, kêt qủa ngon lành mà hok biết đứng hok HIC

Ba Tê · 20/8/12

overnight_9 đã viết:
kg: Thầy Bate,
Cám ơn thầy nhiều em có thêm 1 sub nưa là:

PHP:

Private Sub CommandButton1_Click() Range("A5:C65000").ClearContents Range("A5:C65000").Interior.ColorIndex = 0 End Sub

kích hoạt sub này thì sư kiên change lỗi biên

Else
Cll.Offset(, -1) = ""

nhưng em dùng bàn phím delete thì không bị lỗi, vậy khắc phục thế nào vây thầy?

Thêm vào Sub của bạn 2 dòng này thử xem.

PHP:

Private Sub CommandButton1_Click()
Application.EnableEvents = False ''"--------1"
    Range("A5:C65000").ClearContents
    Range("A5:C65000").Interior.ColorIndex = 0
Application.EnableEvents = True ''"-------- 2"
End Sub

Để tránh phiền lỗi chữ hoa chữ thường, bạn tìm và thêm Ucase vào dòng này cho chắc ăn một chút.

PHP:

If UCase(Rng(I, 1)) = UCase(Cll.Value) Then

Sư kiện worksheet_Change.

strive for mastery

Huyền thoại GPE

strive for mastery

File đính kèm

Huyền thoại GPE

File đính kèm

Bad Excel Member

Huyền thoại GPE

Bad Excel Member

strive for mastery

Bad Excel Member

strive for mastery

File đính kèm

Gội rồi mới Cạo

strive for mastery

strive for mastery

File đính kèm

Cạo Rồi Khỏi Gội

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

strive for mastery

strive for mastery

Cạo Rồi Khỏi Gội

Facebook

Group