Tự động nhập liệu dựa vào mã cho trước

[lp0072021]

Chào anh/chị,
Em có cột F chứa những mã cho trước, nhờ anh chị giúp em:
1. Những ô ở cột D chưa có số liệu thì khi nhập vào ô bất kỳ thì tự động điền cùng dữ liệu đó cho những ô còn lại nếu điều kiện có cùng mã phường ở cột F
ví dụ : đánh vào chữ "kẹo" ở ô D14 cho mã phường P03, thì tự động điền ô D10,D13 sẽ có kết quả là "Kẹo"
2. Khi đã nhập liệu vào rồi, nếu sửa dữ liệu ở cột D dẫn đến cùng một mã phường ở cột F mà khác tên ở cột D thì có 2 lựa chọn:
+Lựa chọn 1: Cho sửa ô cần sửa và giữ nguyên những ô còn lại (ví dụ sửa "Kẹo" thành "Bánh" ở ô D13 nhưng vẫn giữ nguyên ô D14 và D10 là "Kẹo"
+ Lựa chọn 2 : Khi sửa thì sẽ cập nhập thay đổi lại tất cả ( ví dụ sửa "Kẹo" thành "Bánh" ở ô D13 thì tất cả các ô D10,D13,D14 đều có kết quả là “ Bánh”

 

[bebo021999]

Vậy ai là người lựa chọn? Có phải là khi nhập liệu xong thì hiện ra input box cho bạn chọn phương án 1 hoặc 2?

 

[lp0072021]

Vậy ai là người lựa chọn? Có phải là khi nhập liệu xong thì hiện ra input box cho bạn chọn phương án 1 hoặc 2?

Khi mình sửa thì chỉ hiện hộp thoại thông báo “ có cập nhập lại tất cả ? “ nếu có thì tất cả các ô D10,D13,D14 chuyển từ “kẹo” sang “bánh”, còn lựa chọn không thì chỉ mình ô D13 chuyển thành “Bánh” các ô D10,D14 vẫn giữ nguyên.

 

[bebo021999]

Click chuột phải trên tên sheet, viewcode rồi dán code này vào:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&, f, k&, u As Range
lr = Cells(Rows.Count, "F").End(xlUp).Row
If Intersect(Target, Range("D8:D" & lr)) Is Nothing Or IsEmpty(Target) Or Target.Count > 1 Then Exit Sub
If MsgBox("Co muon cap nhat lai tat ca?", vbYesNo) = vbNo Then Exit Sub
Set f = Range("F8:F" & lr).Find(Target.Offset(0, 2).Value, Range("F8"))
If Not f Is Nothing Then
   Do Until k > lr - 7
        k = k + 1
        If u Is Nothing Then
            Set u = f.Offset(0, -2)
        Else
            Set u = Union(u, f.Offset(0, -2))
        End If
        Set f = Range("F8:F" & lr).FindNext(f)
    Loop
    u.Value = Target.Value
End If
End Sub

 

[lp0072021]

Click chuột phải trên tên sheet, viewcode rồi dán code này vào:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&, f, k&, u As Range
lr = Cells(Rows.Count, "F").End(xlUp).Row
If Intersect(Target, Range("D8:D" & lr)) Is Nothing Or IsEmpty(Target) Or Target.Count > 1 Then Exit Sub
If MsgBox("Co muon cap nhat lai tat ca?", vbYesNo) = vbNo Then Exit Sub
Set f = Range("F8:F" & lr).Find(Target.Offset(0, 2).Value, Range("F8"))
If Not f Is Nothing Then
   Do Until k > lr - 7
        k = k + 1
        If u Is Nothing Then
            Set u = f.Offset(0, -2)
        Else
            Set u = Union(u, f.Offset(0, -2))
        End If
        Set f = Range("F8:F" & lr).FindNext(f)
    Loop
    u.Value = Target.Value
End If
End Sub

Muốn cột D chưa có dữ liệu nhập vào ( tức nhập lúc ban đầu số liệu cốn trống ) thì tự động điền cho tất cả các ô D10,D13,D14, nhưng sau đó có 1 ô nào đó chỉnh sửa khác số liệu với các ô còn lại thì hộp thoại thông báo mới thực hiện để chọn lựa cập nhập tất cả hay giữ nguyên các ô khác. Cảm ơn bạn nhiều.

 

[bebo021999]

Thử lại nhé:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&, f, k&, u As Range, cell As Range
lr = Cells(Rows.Count, "F").End(xlUp).Row
If Intersect(Target, Range("D8:D" & lr)) Is Nothing Or IsEmpty(Target) Or Target.Count > 1 Then Exit Sub
Set f = Range("F8:F" & lr).Find(Target.Offset(0, 2).Value, Range("F8"))
If Not f Is Nothing Then
   Do Until k > lr - 7
        k = k + 1
        If u Is Nothing Then
            Set u = f.Offset(0, -2)
        Else
            Set u = Union(u, f.Offset(0, -2))
        End If
        Set f = Range("F8:F" & lr).FindNext(f)
    Loop
End If
For Each cell In u
    If Not IsEmpty(cell.Value) And cell.Value <> Target.Value Then
        If MsgBox("Co muon cap nhat lai tat ca?", vbYesNo) = vbNo Then
            Exit Sub
        Else: Exit For
        End If
    End If
Next
u.Value = Target.Value
End Sub

 

[lp0072021]

Thử lại nhé:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&, f, k&, u As Range, cell As Range
lr = Cells(Rows.Count, "F").End(xlUp).Row
If Intersect(Target, Range("D8:D" & lr)) Is Nothing Or IsEmpty(Target) Or Target.Count > 1 Then Exit Sub
Set f = Range("F8:F" & lr).Find(Target.Offset(0, 2).Value, Range("F8"))
If Not f Is Nothing Then
   Do Until k > lr - 7
        k = k + 1
        If u Is Nothing Then
            Set u = f.Offset(0, -2)
        Else
            Set u = Union(u, f.Offset(0, -2))
        End If
        Set f = Range("F8:F" & lr).FindNext(f)
    Loop
End If
For Each cell In u
    If Not IsEmpty(cell.Value) And cell.Value <> Target.Value Then
        If MsgBox("Co muon cap nhat lai tat ca?", vbYesNo) = vbNo Then
            Exit Sub
        Else: Exit For
        End If
    End If
Next
u.Value = Target.Value
End Sub

Cảm ơn bạn nhiều nhé!

 

[lp0072021]

Thử lại nhé:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&, f, k&, u As Range, cell As Range
lr = Cells(Rows.Count, "F").End(xlUp).Row
If Intersect(Target, Range("D8:D" & lr)) Is Nothing Or IsEmpty(Target) Or Target.Count > 1 Then Exit Sub
Set f = Range("F8:F" & lr).Find(Target.Offset(0, 2).Value, Range("F8"))
If Not f Is Nothing Then
   Do Until k > lr - 7
        k = k + 1
        If u Is Nothing Then
            Set u = f.Offset(0, -2)
        Else
            Set u = Union(u, f.Offset(0, -2))
        End If
        Set f = Range("F8:F" & lr).FindNext(f)
    Loop
End If
For Each cell In u
    If Not IsEmpty(cell.Value) And cell.Value <> Target.Value Then
        If MsgBox("Co muon cap nhat lai tat ca?", vbYesNo) = vbNo Then
            Exit Sub
        Else: Exit For
        End If
    End If
Next
u.Value = Target.Value
End Sub

Nhờ bạn xem lại giúp mình khi mã ở cột F chỉ có 1 mã duy nhất thì lại báo lỗi như vậy. cảm ơn bạn

 

[Quangthanh_hocvba]

Sao bạn không tạo 1 sheet data nhỉ.? Mã phường sẻ tự lấy dữ liệu từ sheet data bạn chỉ cần thay đổi mã phường ở ô F là tự nó cập nhật