vẽ vòng tròn Oval theo vị trí định sẵn

Liên hệ QC
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
 
Web KT
Back
Top Bottom