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.
vẽ vòng tròn Oval theo vị trí định sẵn
- Thread starter hic1802
- Ngày gửi
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 SubPi-Pikachu
Thành viên chính thức
- Tham gia
- 22/2/21
- Bài viết
- 71
- Được thích
- 22
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.Vd.
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:
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 Subcảm ơn bác rất nhiều a
Bài viết mới nhất
- Đã giải quyết
- Question
