vẽ vòng tròn Oval theo vị trí định sẵn (1 người xem)

  • Thread starter Thread starter hic1802
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

hic1802

Thành viên tiêu biểu
Tham gia
16/2/13
Bài viết
545
Được thích
34
Giới tính
Nam
Xin chào mọi người trên GPE,
Hôm nay em có bài toán nhờ mọi người giúp đỡ là : làm sao để vẽ chèn biểu tượng Oval vào đúng vị trí mình mong muốn tự động như hình phía dưới tức là khi ta điền nội dung vào 3 cột A,B,C thì sẽ tự động chèn Oval (với tên được đặt như cột C) vào vị trí ô cell như trục tọa độ cột A và cột B.
Em xin cảm ơn.
Untitled.png
 

File đính kèm

Thử nhé.

1. Sửa lại trục X là hướng sang phải, trục Y hướng lên trên.

2. Phải chuột trên tên sheet ở "sheet tabs" ở dưới cùg -> View code -> dán code sau
Mã:
Private Sub Worksheet_Change(ByVal Target As range)
Dim cell_ As range, x As Long, y As Long, a As Long
    If Target.Row < 3 Or Target.Column > 3 Or Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
   
    If Target.Column < 3 Then
        If Not IsNumeric(Target.Value) Then
            MsgBox "Toa do khong la gia tri so"
            Target.Value = Empty
        Else
            If Target.Column = 1 Then
                a = Me.range("F11").Column + Target.Value
            Else
                a = Me.range("F11").Row - Target.Value
            End If
            If a < 1 Then
                MsgBox "Toa do x hoac y khong hop le"
                Target.Value = Empty
            End If
            a = Target.Value
            Target.Value = a
        End If
    End If
    Application.EnableEvents = True
    Set cell_ = Target.Offset(, 1 - Target.Column)
    If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(cell_.Offset(, 2).Value) > 0 Then
        Set cell_ = Me.range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
        With Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
            .Fill.Visible = msoFalse
            .Name = Target.Offset(, 3 - Target.Column).Value
        End With
    End If
End Sub

Nếu nhập tọa độ x âm hoặc y âm thì tính về bên trái hoặc xuống dưới. Nếu tính về bên trái hoặc lên trên mà ra khỏi trang tính thì code báo lỗi. Nếu nhập tọa độ có phần thập phân thì code sẽ làm tròn.
 
Thử nhé.

1. Sửa lại trục X là hướng sang phải, trục Y hướng lên trên.

2. Phải chuột trên tên sheet ở "sheet tabs" ở dưới cùg -> View code -> dán code sau
Mã:
Private Sub Worksheet_Change(ByVal Target As range)
Dim cell_ As range, x As Long, y As Long, a As Long
    If Target.Row < 3 Or Target.Column > 3 Or Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
 
    If Target.Column < 3 Then
        If Not IsNumeric(Target.Value) Then
            MsgBox "Toa do khong la gia tri so"
            Target.Value = Empty
        Else
            If Target.Column = 1 Then
                a = Me.range("F11").Column + Target.Value
            Else
                a = Me.range("F11").Row - Target.Value
            End If
            If a < 1 Then
                MsgBox "Toa do x hoac y khong hop le"
                Target.Value = Empty
            End If
            a = Target.Value
            Target.Value = a
        End If
    End If
    Application.EnableEvents = True
    Set cell_ = Target.Offset(, 1 - Target.Column)
    If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(cell_.Offset(, 2).Value) > 0 Then
        Set cell_ = Me.range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
        With Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
            .Fill.Visible = msoFalse
            .Name = Target.Offset(, 3 - Target.Column).Value
        End With
    End If
End Sub

Nếu nhập tọa độ x âm hoặc y âm thì tính về bên trái hoặc xuống dưới. Nếu tính về bên trái hoặc lên trên mà ra khỏi trang tính thì code báo lỗi. Nếu nhập tọa độ có phần thập phân thì code sẽ làm tròn.
Hay quá bác, bác có thể thêm chức năng: khi mình xóa dữ liệu ở cột A, B, C thì vòng tròn cũng bị xóa đi không ạ?
 
hic1802 đã viết:
Hôm nay em có bài toán nhờ mọi người giúp đỡ là : làm sao để vẽ chèn biểu tượng Oval vào đúng vị trí mình mong muốn tự động như hình phía dưới tức là khi ta điền nội dung vào 3 cột A,B,C thì sẽ tự động chèn Oval (với tên được đặt như cột C) vào vị trí ô cell như trục tọa độ cột A và cột B.
Vẽ đồ thị thì đâu cần code. Thêm bớt dữ liệu đều tự động cả. Âm dương, nguyên phân đều được luôn


1623418770180.png
 

File đính kèm

Lần chỉnh sửa cuối:
Tôi thì lại hiểu là vẽ oval TRÊN SHEET, tức chả liên quan gì tới đồ thị cả. Nếu là vẽ đồ thị thì người ta phải chèn Chart trong ví dụ chứ nhỉ.
À, ý tôi không nói anh mà là nói chủ đề tài. Nếu dùng biểu đồ thay cho vẽ trên sheet thì đơn giản hơn. Mà cũng có thể muốn vẽ chart mà minh hoạ bằng cells không chừng.
 
Thử nhé.

1. Sửa lại trục X là hướng sang phải, trục Y hướng lên trên.

2. Phải chuột trên tên sheet ở "sheet tabs" ở dưới cùg -> View code -> dán code sau
Mã:
Private Sub Worksheet_Change(ByVal Target As range)
Dim cell_ As range, x As Long, y As Long, a As Long
    If Target.Row < 3 Or Target.Column > 3 Or Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
  
    If Target.Column < 3 Then
        If Not IsNumeric(Target.Value) Then
            MsgBox "Toa do khong la gia tri so"
            Target.Value = Empty
        Else
            If Target.Column = 1 Then
                a = Me.range("F11").Column + Target.Value
            Else
                a = Me.range("F11").Row - Target.Value
            End If
            If a < 1 Then
                MsgBox "Toa do x hoac y khong hop le"
                Target.Value = Empty
            End If
            a = Target.Value
            Target.Value = a
        End If
    End If
    Application.EnableEvents = True
    Set cell_ = Target.Offset(, 1 - Target.Column)
    If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(cell_.Offset(, 2).Value) > 0 Then
        Set cell_ = Me.range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
        With Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
            .Fill.Visible = msoFalse
            .Name = Target.Offset(, 3 - Target.Column).Value
        End With
    End If
End Sub

Nếu nhập tọa độ x âm hoặc y âm thì tính về bên trái hoặc xuống dưới. Nếu tính về bên trái hoặc lên trên mà ra khỏi trang tính thì code báo lỗi. Nếu nhập tọa độ có phần thập phân thì code sẽ làm tròn.
Hay quá, vậy làm sao để khi thay đổi chỉ số thì các vòng tròn cũng tự động xóa vị trí cũ rồi cập nhật vào vị trí mới vậy bạn ?
 
Hay quá bác, bác có thể thêm chức năng: khi mình xóa dữ liệu ở cột A, B, C thì vòng tròn cũng bị xóa đi không ạ?
Hay quá, vậy làm sao để khi thay đổi chỉ số thì các vòng tròn cũng tự động xóa vị trí cũ rồi cập nhật vào vị trí mới vậy bạn ?
Thử kiểm tra xem, tôi không test kỹ.

Xóa ở cột C (A và B không bắt buộc) thì xóa Oval.

Mã:
Private Sub Worksheet_Change(ByVal Target As range)
Dim cell_ As range, x As Long, y As Long, a As Long
    If Target.Row < 3 Or Target.Column > 3 Or Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
    
    If Target.Column < 3 Then
        If Not IsNumeric(Target.Value) Then
            MsgBox "Toa do khong la gia tri so"
            Target.Value = Empty
        Else
            If Target.Column = 1 Then
                a = Me.range("F11").Column + Target.Value
            Else
                a = Me.range("F11").Row - Target.Value
            End If
            If a < 1 Then
                MsgBox "Toa do x hoac y khong hop le"
                Target.Value = Empty
            End If
            a = Target.Value
            Target.Value = a
        End If
    Else
        If Len(Target.Value) = 0 Then
            Application.Undo
            On Error Resume Next
            Me.Shapes(Target.Value).Delete
            On Error GoTo 0
            Target.Value = Empty
        End If
    End If
    Application.EnableEvents = True
    Set cell_ = Target.Offset(, 1 - Target.Column)
    If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(cell_.Offset(, 2).Value) > 0 Then
        On Error Resume Next
        Me.Shapes(Target.Offset(, 3 - Target.Column).Value).Delete
        On Error GoTo 0
        Set cell_ = Me.range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
        With Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
            .Fill.Visible = msoFalse
            .Name = Target.Offset(, 3 - Target.Column).Value
        End With
    End If
End Sub
 
Thử kiểm tra xem, tôi không test kỹ.

Xóa ở cột C (A và B không bắt buộc) thì xóa Oval.

Mã:
Private Sub Worksheet_Change(ByVal Target As range)
Dim cell_ As range, x As Long, y As Long, a As Long
    If Target.Row < 3 Or Target.Column > 3 Or Target.Count > 1 Then Exit Sub
    Application.EnableEvents = False
   
    If Target.Column < 3 Then
        If Not IsNumeric(Target.Value) Then
            MsgBox "Toa do khong la gia tri so"
            Target.Value = Empty
        Else
            If Target.Column = 1 Then
                a = Me.range("F11").Column + Target.Value
            Else
                a = Me.range("F11").Row - Target.Value
            End If
            If a < 1 Then
                MsgBox "Toa do x hoac y khong hop le"
                Target.Value = Empty
            End If
            a = Target.Value
            Target.Value = a
        End If
    Else
        If Len(Target.Value) = 0 Then
            Application.Undo
            On Error Resume Next
            Me.Shapes(Target.Value).Delete
            On Error GoTo 0
            Target.Value = Empty
        End If
    End If
    Application.EnableEvents = True
    Set cell_ = Target.Offset(, 1 - Target.Column)
    If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(cell_.Offset(, 2).Value) > 0 Then
        On Error Resume Next
        Me.Shapes(Target.Offset(, 3 - Target.Column).Value).Delete
        On Error GoTo 0
        Set cell_ = Me.range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
        With Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
            .Fill.Visible = msoFalse
            .Name = Target.Offset(, 3 - Target.Column).Value
        End With
    End If
End Sub
Hay quá cảm ơn bạn, khi xóa một ô trong cột A hoặc B thì chuẩn rồi nhưng nếu xóa toàn bộ từ 2 ô trở lên thì code không hoạt động.
Tương tự khi nhập cũng vậy nhập một ô thì chuẩn rồi nhưng nếu nhập 1 lúc nhiều ô thì code cũng không hoạt động.
 
Hay quá cảm ơn bạn, khi xóa một ô trong cột A hoặc B thì chuẩn rồi nhưng nếu xóa toàn bộ từ 2 ô trở lên thì code không hoạt động.
Tương tự khi nhập cũng vậy nhập một ô thì chuẩn rồi nhưng nếu nhập 1 lúc nhiều ô thì code cũng không hoạt động.
Đọc code sẽ thấy thôi: Or Target.Count > 1 Then Exit Sub
 
Hay quá cảm ơn bạn, khi xóa một ô trong cột A hoặc B thì chuẩn rồi nhưng nếu xóa toàn bộ từ 2 ô trở lên thì code không hoạt động.
Tương tự khi nhập cũng vậy nhập một ô thì chuẩn rồi nhưng nếu nhập 1 lúc nhiều ô thì code cũng không hoạt động.
Thì chủ ý của tôi là vậy mà. Trích code
Or Target.Count > 1 Then Exit Sub
 
Sửa đoạn này cũng đâu có giải quyết được trường hợp nhập nhiều ô hay xóa nhiều ô cùng một lúc bạn nhỉ.
Bạn thử chưa? và thử sửa thế nào?
Tuy nhiên nếu sửa để cho có thể điền cùng lúc hoặc xoá cùng lúc nhiều ô, sẽ phải xử lý nhiều tình huống gây lỗi khác, hoặc tình huống phải rẽ nhánh nhiều hơn.
 
Bạn thử chưa? và thử sửa thế nào?
Tuy nhiên nếu sửa để cho có thể điền cùng lúc hoặc xoá cùng lúc nhiều ô, sẽ phải xử lý nhiều tình huống gây lỗi khác, hoặc tình huống phải rẽ nhánh nhiều hơn.

Tôi thử như sau:
trong code bỏ: Or Target.Count > 1

trên bảng tính chọn những ô màu đỏ:
1623488787428.png


Kết quả sau khi nhập:
1623488838107.png


Kết quả phải là (có 2 vòng tròn vì trùng tọa độ nên đè lên nhau kéo ra là thấy) :

1623488913167.png


Chọn 3 ô màu đỏ rồi xóa, kết quả là tọa độ 3,5 vẫn còn hình tròn:
1623488992813.png

nên tôi mới thông tin "sửa đoạn này (bỏ Or Target.Count > 1 ) cũng đâu có giải quyết được trường hợp nhập nhiều ô hay xóa nhiều ô cùng một lúc"
 
nên tôi mới thông tin "sửa đoạn này (bỏ Or Target.Count > 1 ) cũng đâu có giải quyết được trường hợp nhập nhiều ô hay xóa nhiều ô cùng một lúc"
Suy nghĩ một chút đi. Không thể chỉ đơn thuần xóa Or Target.Count > 1. Toàn bộ code sau dòng đầu tiên được viết cho trường hợp Target.Count = 1. Vì với Target.Count > 1 thì đã có Exit Sub rồi nên code sau dòng 1 sẽ không được thực hiện. Code từ dòng 2 được viết cho trường hợp Target.Count = 1 nên nó không xét những tình huống sảy ra khi Target.Count > 1. Chính vì thế xóa Or Target.Count > 1 không đủ vì code đi tiếp nhưng phần đi tiếp không phục vụ Target.Count > 1.

Lúc trước khi nhập tọa độ không hợp lệ (chữ, hoặc tọa độ ngoài trang tính) thì có MsgBox. Bây giờ phục vụ nhập và xóa nhiều ô nên không nên dùng MsgBox nữa. Khi nhập tọa độ không hợp lệ thì code biến chúng thành 0.

Mã:
Private Sub Worksheet_Change(ByVal Target As range)
Dim shp As Shape, cell_ As range, dong As range, rng As range, a As Long, ten As String
    Set rng = Intersect(Me.range("A3:C1000"), Target)
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    On Error Resume Next
    For Each shp In Me.Shapes
        If Application.CountIf(Me.range("C3:C1000"), shp.Name) = 0 Then shp.Delete
    Next shp
    On Error Resume Next
    For Each cell_ In rng
        If cell_.Column < 3 Then
            If Not IsNumeric(cell_.Value) Then
                cell_.Value = Empty
            Else
                If cell_.Column = 1 Then
                    a = Me.range("F11").Column + cell_.Value
                Else
                    a = Me.range("F11").Row - cell_.Value
                End If
                If a < 1 Then cell_.Value = Empty
                a = cell_.Value
                cell_.Value = a
            End If
        End If
    Next cell_

    Application.EnableEvents = True

    For Each dong In rng
        Set cell_ = Me.range("A" & dong.Row)
        ten = cell_.Offset(, 2).Value
        If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(ten) > 0 Then
            On Error Resume Next
            Me.Shapes(ten).Delete
            On Error GoTo 0
            Set cell_ = Me.range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
            With Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
                .Fill.Visible = msoFalse
                .Name = ten
            End With
        End If
    Next dong
End Sub
 
Lần chỉnh sửa cuối:
Suy nghĩ một chút đi. Không thể chỉ đơn thuần xóa Or Target.Count > 1. Toàn bộ code sau dòng đầu tiên được viết cho trường hợp Target.Count = 1. Vì với Target.Count > 1 thì đã có Exit Sub rồi nên code sau dòng 1 sẽ không được thực hiện. Code từ dòng 2 được viết cho trường hợp Target.Count = 1 nên nó không xét những tình huống sảy ra khi Target.Count > 1. Chính vì thế xóa Or Target.Count > 1 không đủ vì code đi tiếp nhưng phần đi tiếp không phục vụ Target.Count > 1.

Lúc trước khi nhập tọa độ không hợp lệ (chữ, hoặc tọa độ ngoài trang tính) thì có MsgBox. Bây giờ phục vụ nhập và xóa nhiều ô nên không nên dùng MsgBox nữa. Khi nhập tọa độ không hợp lệ thì code biến chúng thành 0.

Mã:
Private Sub Worksheet_Change(ByVal Target As range)
Dim shp As Shape, cell_ As range, dong As range, rng As range, a As Long, ten As String
    Set rng = Intersect(Me.range("A3:C1000"), Target)
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    On Error Resume Next
    For Each shp In Me.Shapes
        If Application.CountIf(Me.range("C3:C1000"), shp.Name) = 0 Then shp.Delete
    Next shp
    On Error Resume Next
    For Each cell_ In rng
        If cell_.Column < 3 Then
            If Not IsNumeric(cell_.Value) Then
                cell_.Value = Empty
            Else
                If cell_.Column = 1 Then
                    a = Me.range("F11").Column + cell_.Value
                Else
                    a = Me.range("F11").Row - cell_.Value
                End If
                If a < 1 Then cell_.Value = Empty
                a = cell_.Value
                cell_.Value = a
            End If
        End If
    Next cell_

    Application.EnableEvents = True

    For Each dong In rng
        Set cell_ = Me.range("A" & dong.Row)
        ten = cell_.Offset(, 2).Value
        If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(ten) > 0 Then
            On Error Resume Next
            Me.Shapes(ten).Delete
            On Error GoTo 0
            Set cell_ = Me.range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
            With Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
                .Fill.Visible = msoFalse
                .Name = ten
                .AlternativeText = cell_.Address
            End With
        End If
    Next dong
End Sub
Hay , quá hay luôn , cảm ơn bạn nhiều.
 
Tôi thử như sau:
trong code bỏ: Or Target.Count > 1
Tôi có nói rõ là nếu sửa (như xoá bỏ vụ >1), thì phải lường trước những tình huống gây lỗi và tình huống phải rẽ nhánh. nghĩa là:
- Tô khối nhiều ô bao gồm cả cột A và B, hoặc bao gồm cả B và C. Phải duyệt qua từng ô để xử lý nếu không sẽ lỗi hoặc chạy sai.
- Tô khối nhiều cột bao gồm A, B, C và cả D, E; xoá hoặc nhập liệu (có thể nhập bằng copy paste) : Xoá phải xử lý khác, nhập liệu phải xử lý khác, nhưng cũng phải duyệt lại từng ô
- Nhấn control tô nhiều ô hoặc nhiều khối ô, cũng là 1 tình huống khác phải xử lý

Chứ tôi đâu có bảo "chỉ xoá đi" đâu?
 
:D trên GPE này đúng là toàn các cao thủ thôi haha,
Nếu bây giờ em hỏi câu khó hơn nữa là vẽ theo màu và theo kích thước thì sẽ như thế nào các bác nhỉ?
Em vẫn lấy ví dụ trên nhé
Bài đã được tự động gộp:

Suy nghĩ một chút đi. Không thể chỉ đơn thuần xóa Or Target.Count > 1. Toàn bộ code sau dòng đầu tiên được viết cho trường hợp Target.Count = 1. Vì với Target.Count > 1 thì đã có Exit Sub rồi nên code sau dòng 1 sẽ không được thực hiện. Code từ dòng 2 được viết cho trường hợp Target.Count = 1 nên nó không xét những tình huống sảy ra khi Target.Count > 1. Chính vì thế xóa Or Target.Count > 1 không đủ vì code đi tiếp nhưng phần đi tiếp không phục vụ Target.Count > 1.

Lúc trước khi nhập tọa độ không hợp lệ (chữ, hoặc tọa độ ngoài trang tính) thì có MsgBox. Bây giờ phục vụ nhập và xóa nhiều ô nên không nên dùng MsgBox nữa. Khi nhập tọa độ không hợp lệ thì code biến chúng thành 0.

Mã:
Private Sub Worksheet_Change(ByVal Target As range)
Dim shp As Shape, cell_ As range, dong As range, rng As range, a As Long, ten As String
    Set rng = Intersect(Me.range("A3:C1000"), Target)
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    On Error Resume Next
    For Each shp In Me.Shapes
        If Application.CountIf(Me.range("C3:C1000"), shp.Name) = 0 Then shp.Delete
    Next shp
    On Error Resume Next
    For Each cell_ In rng
        If cell_.Column < 3 Then
            If Not IsNumeric(cell_.Value) Then
                cell_.Value = Empty
            Else
                If cell_.Column = 1 Then
                    a = Me.range("F11").Column + cell_.Value
                Else
                    a = Me.range("F11").Row - cell_.Value
                End If
                If a < 1 Then cell_.Value = Empty
                a = cell_.Value
                cell_.Value = a
            End If
        End If
    Next cell_

    Application.EnableEvents = True

    For Each dong In rng
        Set cell_ = Me.range("A" & dong.Row)
        ten = cell_.Offset(, 2).Value
        If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(ten) > 0 Then
            On Error Resume Next
            Me.Shapes(ten).Delete
            On Error GoTo 0
            Set cell_ = Me.range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
            With Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
                .Fill.Visible = msoFalse
                .Name = ten
            End With
        End If
    Next dong
End Sub
Cái này theo em hiểu là tìm vị trí rồi tạo shapes nhưng em ko biết đặt shape đó tại vị trí (trục X,Y) như thế nào?
câu này có nghĩa là như cách em hiểu đùng ko bác : Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
 

File đính kèm

Lần chỉnh sửa cuối:
Suy nghĩ một chút đi. Không thể chỉ đơn thuần xóa Or Target.Count > 1. Toàn bộ code sau dòng đầu tiên được viết cho trường hợp Target.Count = 1. Vì với Target.Count > 1 thì đã có Exit Sub rồi nên code sau dòng 1 sẽ không được thực hiện. Code từ dòng 2 được viết cho trường hợp Target.Count = 1 nên nó không xét những tình huống sảy ra khi Target.Count > 1. Chính vì thế xóa Or Target.Count > 1 không đủ vì code đi tiếp nhưng phần đi tiếp không phục vụ Target.Count > 1.

Lúc trước khi nhập tọa độ không hợp lệ (chữ, hoặc tọa độ ngoài trang tính) thì có MsgBox. Bây giờ phục vụ nhập và xóa nhiều ô nên không nên dùng MsgBox nữa. Khi nhập tọa độ không hợp lệ thì code biến chúng thành 0.

Mã:
Private Sub Worksheet_Change(ByVal Target As range)
Dim shp As Shape, cell_ As range, dong As range, rng As range, a As Long, ten As String
    Set rng = Intersect(Me.range("A3:C1000"), Target)
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    On Error Resume Next
    For Each shp In Me.Shapes
        If Application.CountIf(Me.range("C3:C1000"), shp.Name) = 0 Then shp.Delete
    Next shp
    On Error Resume Next
    For Each cell_ In rng
        If cell_.Column < 3 Then
            If Not IsNumeric(cell_.Value) Then
                cell_.Value = Empty
            Else
                If cell_.Column = 1 Then
                    a = Me.range("F11").Column + cell_.Value
                Else
                    a = Me.range("F11").Row - cell_.Value
                End If
                If a < 1 Then cell_.Value = Empty
                a = cell_.Value
                cell_.Value = a
            End If
        End If
    Next cell_

    Application.EnableEvents = True

    For Each dong In rng
        Set cell_ = Me.range("A" & dong.Row)
        ten = cell_.Offset(, 2).Value
        If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(ten) > 0 Then
            On Error Resume Next
            Me.Shapes(ten).Delete
            On Error GoTo 0
            Set cell_ = Me.range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
            With Me.Shapes.AddShape(msoShapeOval, cell_.left, cell_.top, cell_.Width, cell_.Height)
                .Fill.Visible = msoFalse
                .Name = ten
            End With
        End If
    Next dong
End Sub
bác ơi, có cách nào chỉ xóa định dạng là vòng tròn Oval còn các shape khác ko xóa được không? Nếu có thì phải chỉnh code như thế nào?
 
bác ơi, có cách nào chỉ xóa định dạng là vòng tròn Oval còn các shape khác ko xóa được không? Nếu có thì phải chỉnh code như thế nào?
Tôi không hiểu.

Xóa định dạng nghĩa là gì?

Là vòng tròn Oval có nghĩa là gì? Oval nào? Là Oval bay lên trời, rơi xuống đất, hay là Oval tan thành mây khói?
 
Tôi không hiểu.

Xóa định dạng nghĩa là gì?

Là vòng tròn Oval có nghĩa là gì? Oval nào? Là Oval bay lên trời, rơi xuống đất, hay là Oval tan thành mây khói?
dạ ví dụ là em còn vẽ thêm các hình khác nữa (ngoài hình Oval, hình vuông, hình tam giác, ...) còn hình oval là chỉ vẽ khi có vị trí theo cột ABC
Nếu xóa cột ABC thì chỉ xóa các hình Oval liên quan mà ko xóa các hình khác.
 
dạ ví dụ là em còn vẽ thêm các hình khác nữa (ngoài hình Oval, hình vuông, hình tam giác, ...) còn hình oval là chỉ vẽ khi có vị trí theo cột ABC
Nếu xóa cột ABC thì chỉ xóa các hình Oval liên quan mà ko xóa các hình khác.
Lần sau viết cho đủ từ đủ nghĩa nhé. Tự dưng lại viết câu cụt. Ít ra phải là: "bác ơi, có cách nào chỉ xóa định dạng là vòng tròn Oval tương ứng sẽ bị xóa còn các shape khác ko xóa được không? Nếu có thì phải chỉnh code như thế nào? "

Thử code mới, viết cho 4 cột - kể cả cột Mã mầu ở D, nhưng gốc tọa độ ở F11 như bài #1 chứ không phải ở G11 như ở bài #18.

Lưu ý: hiện thời có 4 ô mầu ở AB2, AB3, AB4 và AB5. Vì thế có hằng số o_tieu_de_cot_mau = "AB1". Tức hằng số là địa chỉ ô ngay trên ô mầu đầu tiên. Nếu để các ô mầu ở chỗ khác vd. AK5, AK6, AK7, AK8, AK9, AK10 (6 ô mầu ứng với mã 1, 2, ..., 6) thì sửa thành
Mã:
Const o_tieu_de_cot_mau = "AK4"

Code mới
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Const o_tieu_de_cot_mau = "AB1" ' bat dau tu duoi o_tieu_de_cot_mau la cac o mau lien tiep nhau, vd. AB2, AB3, AB4 va AB5
Dim shp As Shape, cell_ As Range, dong As Range, rng As Range, a As Long, ma_mau As Long, ten As String
    Set rng = Intersect(Me.Range("A3:D1000"), Target)
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    On Error Resume Next
    For Each shp In Me.Shapes
        If shp.AlternativeText = "SecretOval" And Application.CountIf(Me.Range("C3:C1000"), shp.Name) = 0 Then shp.Delete
    Next shp
    On Error Resume Next
    For Each cell_ In rng
        If cell_.Column <> 3 Then
            If Not IsNumeric(cell_.Value) Then
                cell_.Value = Empty
            Else
                If cell_.Column = 1 Then
                    a = Me.Range("F11").Column + cell_.Value
                ElseIf cell_.Column = 2 Then
                    a = Me.Range("F11").Row - cell_.Value
                Else
                    a = cell_.Value
                End If
                If a < 1 Then cell_.Value = Empty
                a = cell_.Value
                cell_.Value = a
            End If
        End If
    Next cell_

    Application.EnableEvents = True

    For Each dong In rng
        Set cell_ = Me.Range("A" & dong.Row)
        ten = cell_.Offset(, 2).Value
        ma_mau = cell_.Offset(, 3).Value
        If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(ten) > 0 And Len(ma_mau) > 0 Then
            On Error Resume Next
            Me.Shapes(ten).Delete
            On Error GoTo 0
            Set cell_ = Me.Range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
            With Me.Shapes.AddShape(msoShapeOval, cell_.Left, cell_.Top, cell_.Width, cell_.Height)
                .Fill.Visible = msoTrue
                .Name = ten
                .AlternativeText = "SecretOval"
                .Fill.ForeColor.RGB = Me.Range(o_tieu_de_cot_mau).Offset(ma_mau).Interior.Color
            End With
        End If
    Next dong
End Sub
 
Lần sau viết cho đủ từ đủ nghĩa nhé. Tự dưng lại viết câu cụt. Ít ra phải là: "bác ơi, có cách nào chỉ xóa định dạng là vòng tròn Oval tương ứng sẽ bị xóa còn các shape khác ko xóa được không? Nếu có thì phải chỉnh code như thế nào? "

Thử code mới, viết cho 4 cột - kể cả cột Mã mầu ở D, nhưng gốc tọa độ ở F11 như bài #1 chứ không phải ở G11 như ở bài #18.

Lưu ý: hiện thời có 4 ô mầu ở AB2, AB3, AB4 và AB5. Vì thế có hằng số o_tieu_de_cot_mau = "AB1". Tức hằng số là địa chỉ ô ngay trên ô mầu đầu tiên. Nếu để các ô mầu ở chỗ khác vd. AK5, AK6, AK7, AK8, AK9, AK10 (6 ô mầu ứng với mã 1, 2, ..., 6) thì sửa thành
Mã:
Const o_tieu_de_cot_mau = "AK4"

Code mới
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Const o_tieu_de_cot_mau = "AB1" ' bat dau tu duoi o_tieu_de_cot_mau la cac o mau lien tiep nhau, vd. AB2, AB3, AB4 va AB5
Dim shp As Shape, cell_ As Range, dong As Range, rng As Range, a As Long, ma_mau As Long, ten As String
    Set rng = Intersect(Me.Range("A3:D1000"), Target)
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    On Error Resume Next
    For Each shp In Me.Shapes
        If shp.AlternativeText = "SecretOval" And Application.CountIf(Me.Range("C3:C1000"), shp.Name) = 0 Then shp.Delete
    Next shp
    On Error Resume Next
    For Each cell_ In rng
        If cell_.Column <> 3 Then
            If Not IsNumeric(cell_.Value) Then
                cell_.Value = Empty
            Else
                If cell_.Column = 1 Then
                    a = Me.Range("F11").Column + cell_.Value
                ElseIf cell_.Column = 2 Then
                    a = Me.Range("F11").Row - cell_.Value
                Else
                    a = cell_.Value
                End If
                If a < 1 Then cell_.Value = Empty
                a = cell_.Value
                cell_.Value = a
            End If
        End If
    Next cell_

    Application.EnableEvents = True

    For Each dong In rng
        Set cell_ = Me.Range("A" & dong.Row)
        ten = cell_.Offset(, 2).Value
        ma_mau = cell_.Offset(, 3).Value
        If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(ten) > 0 And Len(ma_mau) > 0 Then
            On Error Resume Next
            Me.Shapes(ten).Delete
            On Error GoTo 0
            Set cell_ = Me.Range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
            With Me.Shapes.AddShape(msoShapeOval, cell_.Left, cell_.Top, cell_.Width, cell_.Height)
                .Fill.Visible = msoTrue
                .Name = ten
                .AlternativeText = "SecretOval"
                .Fill.ForeColor.RGB = Me.Range(o_tieu_de_cot_mau).Offset(ma_mau).Interior.Color
            End With
        End If
    Next dong
End Sub
Haaay, quá đỉnh! Quá tuyệt vời,
Nhưng mà hình như code chạy nhầm trục X và trục Y theo bảng nhập liệu.
 
Haaay, quá đỉnh! Quá tuyệt vời,
Nhưng mà hình như code chạy nhầm trục X và trục Y theo bảng nhập liệu.
Tôi viết rõ trong bài #2
Mã:
1. Sửa lại trục X là hướng sang phải, trục Y hướng lên trên.
Trong Windows API rất nhiều hàm có tham số x, y.

Vd.
Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Tham số x bao giờ cũng là tính ngang, y - tính dọc.

Hồi xưa học Toán thì bạn có trục X nằm ngang hay dọc?

Trong Windows API trong cái gọi là device context gốc tọa độ nằm ở góc trên bên trái chứ không ở góc dưới bên trái. Tức trục Y hướng xuống dưới.

Tôi chọn trục X nằm ngang vì tôi không mù quáng chấp nhận mọi yêu cầu của người khác. Tôi có đánh giá riêng của tôi. Muốn sự giúp đỡ của tôi thì phải chấp nhận những quyết định của tôi.
 
Lần chỉnh sửa cuối:
Lần sau viết cho đủ từ đủ nghĩa nhé. Tự dưng lại viết câu cụt. Ít ra phải là: "bác ơi, có cách nào chỉ xóa định dạng là vòng tròn Oval tương ứng sẽ bị xóa còn các shape khác ko xóa được không? Nếu có thì phải chỉnh code như thế nào? "

Thử code mới, viết cho 4 cột - kể cả cột Mã mầu ở D, nhưng gốc tọa độ ở F11 như bài #1 chứ không phải ở G11 như ở bài #18.

Lưu ý: hiện thời có 4 ô mầu ở AB2, AB3, AB4 và AB5. Vì thế có hằng số o_tieu_de_cot_mau = "AB1". Tức hằng số là địa chỉ ô ngay trên ô mầu đầu tiên. Nếu để các ô mầu ở chỗ khác vd. AK5, AK6, AK7, AK8, AK9, AK10 (6 ô mầu ứng với mã 1, 2, ..., 6) thì sửa thành
Mã:
Const o_tieu_de_cot_mau = "AK4"

Code mới
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
Const o_tieu_de_cot_mau = "AB1" ' bat dau tu duoi o_tieu_de_cot_mau la cac o mau lien tiep nhau, vd. AB2, AB3, AB4 va AB5
Dim shp As Shape, cell_ As Range, dong As Range, rng As Range, a As Long, ma_mau As Long, ten As String
    Set rng = Intersect(Me.Range("A3:D1000"), Target)
    If rng Is Nothing Then Exit Sub
    Application.EnableEvents = False
    On Error Resume Next
    For Each shp In Me.Shapes
        If shp.AlternativeText = "SecretOval" And Application.CountIf(Me.Range("C3:C1000"), shp.Name) = 0 Then shp.Delete
    Next shp
    On Error Resume Next
    For Each cell_ In rng
        If cell_.Column <> 3 Then
            If Not IsNumeric(cell_.Value) Then
                cell_.Value = Empty
            Else
                If cell_.Column = 1 Then
                    a = Me.Range("F11").Column + cell_.Value
                ElseIf cell_.Column = 2 Then
                    a = Me.Range("F11").Row - cell_.Value
                Else
                    a = cell_.Value
                End If
                If a < 1 Then cell_.Value = Empty
                a = cell_.Value
                cell_.Value = a
            End If
        End If
    Next cell_

    Application.EnableEvents = True

    For Each dong In rng
        Set cell_ = Me.Range("A" & dong.Row)
        ten = cell_.Offset(, 2).Value
        ma_mau = cell_.Offset(, 3).Value
        If Len(cell_.Value) > 0 And Len(cell_.Offset(, 1).Value) > 0 And Len(ten) > 0 And Len(ma_mau) > 0 Then
            On Error Resume Next
            Me.Shapes(ten).Delete
            On Error GoTo 0
            Set cell_ = Me.Range("F11").Offset(-cell_.Offset(, 1).Value, cell_.Value)
            With Me.Shapes.AddShape(msoShapeOval, cell_.Left, cell_.Top, cell_.Width, cell_.Height)
                .Fill.Visible = msoTrue
                .Name = ten
                .AlternativeText = "SecretOval"
                .Fill.ForeColor.RGB = Me.Range(o_tieu_de_cot_mau).Offset(ma_mau).Interior.Color
            End With
        End If
    Next dong
End Sub
em hỏi thêm chút là em muốn tạo sub riêng (không chạy kiểu wooksheet_change) thì phải thay đổi code như nào (kiểu tạo button chạy sub ấy a)
 
em hỏi thêm chút là em muốn tạo sub riêng (không chạy kiểu wooksheet_change) thì phải thay đổi code như nào (kiểu tạo button chạy sub ấy a)
Thử xem
Mã:
Sub ve_hinh()
Const o_tieu_de_cot_mau = "AB1" ' bat dau tu duoi o_tieu_de_cot_mau la cac o mau lien tiep nhau, vd. AB2, AB3, AB4 va AB5
Dim lastRow As Long, r As Long, c As Long, ma_mau As Long, ten As String, dulieu(), shp As Shape, cell_ As Range, sh As Worksheet
    Set sh = ThisWorkbook.Worksheets("Sheet1")
    With sh
        For Each shp In .Shapes
            If shp.AlternativeText = "SecretOval" Then shp.Delete
        Next shp
        lastRow = .Cells(Rows.Count, "D").End(xlUp).Row
        If lastRow < 3 Then Exit Sub
        dulieu = .Range("A3:D" & lastRow).Value
    End With
    For r = 1 To UBound(dulieu, 1)
        ten = dulieu(r, 3)
        ma_mau = dulieu(r, 4)
        If Len(dulieu(r, 1)) > 0 And Len(dulieu(r, 2)) > 0 And Len(ten) > 0 And ma_mau > 0 Then
            Set cell_ = sh.Range("F11").Offset(-dulieu(r, 2), dulieu(r, 1))
            Set shp = sh.Shapes.AddShape(msoShapeOval, cell_.Left, cell_.Top, cell_.Width, cell_.Height)
            With shp
                .Fill.Visible = msoTrue
                .Name = ten
                .AlternativeText = "SecretOval"
                .Fill.ForeColor.RGB = sh.Range(o_tieu_de_cot_mau).Offset(ma_mau).Interior.Color
            End With
        End If
    Next r
End Sub
 
Thử xem
Mã:
Sub ve_hinh()
Const o_tieu_de_cot_mau = "AB1" ' bat dau tu duoi o_tieu_de_cot_mau la cac o mau lien tiep nhau, vd. AB2, AB3, AB4 va AB5
Dim lastRow As Long, r As Long, c As Long, ma_mau As Long, ten As String, dulieu(), shp As Shape, cell_ As Range, sh As Worksheet
    Set sh = ThisWorkbook.Worksheets("Sheet1")
    With sh
        For Each shp In .Shapes
            If shp.AlternativeText = "SecretOval" Then shp.Delete
        Next shp
        lastRow = .Cells(Rows.Count, "D").End(xlUp).Row
        If lastRow < 3 Then Exit Sub
        dulieu = .Range("A3:D" & lastRow).Value
    End With
    For r = 1 To UBound(dulieu, 1)
        ten = dulieu(r, 3)
        ma_mau = dulieu(r, 4)
        If Len(dulieu(r, 1)) > 0 And Len(dulieu(r, 2)) > 0 And Len(ten) > 0 And ma_mau > 0 Then
            Set cell_ = sh.Range("F11").Offset(-dulieu(r, 2), dulieu(r, 1))
            Set shp = sh.Shapes.AddShape(msoShapeOval, cell_.Left, cell_.Top, cell_.Width, cell_.Height)
            With shp
                .Fill.Visible = msoTrue
                .Name = ten
                .AlternativeText = "SecretOval"
                .Fill.ForeColor.RGB = sh.Range(o_tieu_de_cot_mau).Offset(ma_mau).Interior.Color
            End With
        End If
    Next r
End Sub
cảm ơn bác rất nhiều a
 

Bài viết mới nhất

Back
Top Bottom