vẽ vòng tròn Oval theo vị trí định sẵn (2 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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
H

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.
 
batman1 đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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.
Nhấp chuột vào đây để mở rộng...
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:
batman1 đã viết:
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ỉ.
Nhấp chuột vào đây để mở rộng...
À, ý 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.
 
batman1 đã viết:
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.
Nhấp chuột vào đây để mở rộ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 ?
 
hoangtuaotrang_hp_vn đã viết:
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 ạ?
Nhấp chuột vào đây để mở rộng...
Pi-Pikachu đã viết:
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 ?
Nhấp chuột vào đây để mở rộng...
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
 
batman1 đã viết:
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
Nhấp chuột vào đây để mở rộ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.
 
Pi-Pikachu đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Đọc code sẽ thấy thôi: Or Target.Count > 1 Then Exit Sub
 
Pi-Pikachu đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Thì chủ ý của tôi là vậy mà. Trích code
Or Target.Count > 1 Then Exit Sub
Nhấp chuột vào đây để mở rộng...
 
Pi-Pikachu đã viết:
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ỉ.
Nhấp chuột vào đây để mở rộng...
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.
 
ptm0412 đã viết:
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.
Nhấp chuột vào đây để mở rộng...

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"
 
Pi-Pikachu đã viết:
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"
Nhấp chuột vào đây để mở rộng...
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:
batman1 đã viết:
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
Nhấp chuột vào đây để mở rộng...
Hay , quá hay luôn , cảm ơn bạn nhiều.
 
Pi-Pikachu đã viết:
Tôi thử như sau:
trong code bỏ: Or Target.Count > 1
Nhấp chuột vào đây để mở rộng...
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:

batman1 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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:
batman1 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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?
 
hic1802 đã viết:
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?
Nhấp chuột vào đây để mở rộng...
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?
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
16 17 18
Trả lời
351
Đọc
32K
Tuanba1992
Tuanba1992
Anhhe
Em xin nhờ các cao nhân chỉ giáo em cách tính giờ làm việc của nhân viên với ạ Plz (1 người xem)
Trả lời
0
Đọc
6
Anhhe
Anhhe
S
Chức năng refresh trong Pivot khi thêm bớt dòng (1 người xem)
Trả lời
9
Đọc
122
ptm0412
ptm0412
O
XIN ANH CHỊ GIÚP ĐỠ HƯỚNG DẪN CHUYỂN VĂN BẢN THÀNH GIỌNG NÓI TRONG EXCEL Ạ. (5 người xem)
Trả lời
2
Đọc
40
Duy Tùng 9x
Duy Tùng 9x
M
Mọi người giúp e với lỗi này là gì ạ
Trả lời
1
Đọc
42
SA_DQ
SA_DQ
E
Không cho người khác chỉnh sửa cố định dòng và cột trong google sheet
Trả lời
0
Đọc
42
Em khong biet
E
queluatb
  • Question Question
Lấy hóa đơn đầu vào cho hóa đơn đầu ra
Trả lời
5
Đọc
319
queluatb
queluatb
Vu_Thi_Xuan
Lỗi tham chiếu khi dùng Vlookup trong VBA
Trả lời
9
Đọc
352
Vu_Thi_Xuan
Vu_Thi_Xuan
6
  • Question Question
vba tự động lấy dữ liệu từ etabs
Trả lời
2
Đọc
267
VetMini
V
1
Vướng mắc về hàm lấy tên đăng nhập máy tính ạ (1 người xem)
2
Trả lời
20
Đọc
712
198zxc
1
D
Nhờ anh chị xử lý giúp lỗi thực hiện lọc dữ liệu
Trả lời
2
Đọc
471
Hoàng Tuấn 868
H
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024)
    • Thích
2 3
Trả lời
50
Đọc
5K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
xin các cao thủ chỉ cách gỡ lỗi không khởi động được excel
Trả lời
4
Đọc
265
bs2
B
H
Chuyển file *xml hóa đơn điện tử sang excel (1 người xem)
    • Thích
Trả lời
10
Đọc
474
htrunga2
H
D
Nhờ anh chị trên diễn đàn dùng hàm dò tìm dữ liệu trong bảng gửi kèm giúp ạ! (1 người xem)
Trả lời
4
Đọc
148
dangvanphu.it
D
P
Phát âm thanh tiếng việt cho dữ liệu trong file excel
Trả lời
3
Đọc
185
PNQC
P
E
Giúp em tạo gợi ý trong combobox sau khi đã lọc danh sách duy nhất trong combobox đó
Trả lời
11
Đọc
3K
thepkun8x
T
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER
    • Thích
Trả lời
1
Đọc
4K
GPE-Trợ Lý
GPE-Trợ Lý
C
Tính tổng một khách hàng có nhiều mã hàng nhỏ (1 người xem)
2
Trả lời
21
Đọc
417
Phuocam
Phuocam
G
Làm sao để sắp xếp nhiều cột và hàng theo abc vậy ạ ? (1 người xem)
Trả lời
9
Đọc
269
Duy Tùng 9x
Duy Tùng 9x
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom