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.
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.
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.
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.
À, ý 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.
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.
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
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.
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.
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.
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
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
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ý
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é
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)
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
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ạnglà vòng tròn Ovaltươ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.
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ạnglà vòng tròn Ovaltươ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.
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
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.
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ạnglà vòng tròn Ovaltươ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.
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
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
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