Group hình vẽ bằng macro (4 người xem)

[mthuvigo]

Trên file em có 2 hình chữ nhật, 2 hình này sẽ thay đổi kích thước theo số mình nhập vào ở ô A2 và B2. Trong macro Test() em có viết code tự xóa hình đi sau mỗi lần thay đổi dữ liệu ở ô A2 và B2 để vẽ lại.
Em muốn chọn hình chữ nhật để có thể di chuyển và copy nó thành một hình chữ nhật mới nhưng mỗi lần chọn chỉ chọn được có 1 line thôi, không thể chọn nguyên 1 hình chữ nhật được, anh chị giúp em với ạ. Em cảm ơn anh chị nhiều.
File của em đây ạ
http://db.tt/egzz9a3c

 

[mthuvigo]

Mấy anh chị ơi có ai giúp được em không ạ? Em tìm trên google hoài mà không tìm được cách giải quyết.

 

[huuthang_bd]

Trên file em có 2 hình chữ nhật, 2 hình này sẽ thay đổi kích thước theo số mình nhập vào ở ô A2 và B2. Trong macro Test() em có viết code tự xóa hình đi sau mỗi lần thay đổi dữ liệu ở ô A2 và B2 để vẽ lại.
Em muốn chọn hình chữ nhật để có thể di chuyển và copy nó thành một hình chữ nhật mới nhưng mỗi lần chọn chỉ chọn được có 1 line thôi, không thể chọn nguyên 1 hình chữ nhật được, anh chị giúp em với ạ. Em cảm ơn anh chị nhiều.
File của em đây ạ
http://db.tt/egzz9a3c

Thay vì vẽ 4 đường thẳng, sao bạn không vẽ một hình chữ nhật luôn.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Span As Long, Length As Long, Square As Object
On Error Resume Next
If Intersect([A2:B2], Target) Is Nothing Then Exit Sub
Span = [A2].Value:  Length = [B2]
Shapes("Shape1").Delete
Shapes("Shape2").Delete
With Shapes.AddShape(msoShapeRectangle, Span * 48, 120, (Length - Span) * 48, 60)
    .Name = "Shape1"
End With
With Shapes.AddShape(msoShapeRectangle, Span * 48, 255, (Length - Span) * 48, 60)
    .Name = "Shape2"
End With
End Sub

 

[ndu96081631]

Trên file em có 2 hình chữ nhật, 2 hình này sẽ thay đổi kích thước theo số mình nhập vào ở ô A2 và B2. Trong macro Test() em có viết code tự xóa hình đi sau mỗi lần thay đổi dữ liệu ở ô A2 và B2 để vẽ lại.
Em muốn chọn hình chữ nhật để có thể di chuyển và copy nó thành một hình chữ nhật mới nhưng mỗi lần chọn chỉ chọn được có 1 line thôi, không thể chọn nguyên 1 hình chữ nhật được, anh chị giúp em với ạ. Em cảm ơn anh chị nhiều.
File của em đây ạ
http://db.tt/egzz9a3c

Vẽ hình chữ nhật thì cứ vẽ thôi, sao phải nối 4 đường thẳng lại thành hình chữ nhật cho tốn công?
Tôi làm như sau:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim wks As Worksheet, dL As Double, dT As Double, dW As Double, dH As Double
  On Error Resume Next
  If Target.Address = "$A$2" Or Target.Address = "$B$2" Then
    Set wks = Target.Parent
    wks.Shapes("HCN1").Delete [COLOR=#ff0000]''<--- Xóa hình 1[/COLOR]
    wks.Shapes("HCN2").Delete [COLOR=#ff0000]''<--- Xóa hình 2[/COLOR]
    dL = Range("D2").Left  [COLOR=#ff0000]''<--- Vị trí của hình 1[/COLOR]
    dT = Range("D2").Top  [COLOR=#ff0000]''<--- Vị trí của hình 1[/COLOR]
    dW = 20 * Range("B2").Value   [COLOR=#ff0000]''<--- Chiều rộng của hình[/COLOR]
    dH = 20 * Range("A2").Value    [COLOR=#ff0000]''<--- Chiều cao của hình[/COLOR]
    With wks.Shapes.AddShape(1, dL, dT, dW, dH) [COLOR=#ff0000]''<---- Chèn hình chữ nhật 1[/COLOR]
      .Name = "HCN1"  [COLOR=#ff0000]''<--- Đặt tên cho hình 1[/COLOR]
      .Fill.Visible = 0
    End With
    dL = Range("D20").Left  [COLOR=#ff0000]''<--- Vị trí của hình 2[/COLOR]
    dT = Range("D20").Top  [COLOR=#ff0000]''<--- Vị trí của hình 2[/COLOR]
    With wks.Shapes.AddShape(1, dL, dT, dW, dH) [COLOR=#ff0000]''<---- Chèn hình chữ nhật 2[/COLOR]
      .Name = "HCN2"  [COLOR=#ff0000]''<--- Đặt tên cho hình 2[/COLOR]
      .Fill.Visible = 0
    End With
  End If
End Sub

Với giá trị của cell A2 là chiều cao của hình và giá trị cell B2 là chiều rộng hình

 

[mthuvigo]

Mình có thể thực hiện việc thay đổi kích thước như trên đối với 1 hình vẽ được copy bên ngoài vào worksheet không hả anh? Có nghĩa là khi mình cho giá trị ô A2 là 5 và B2 là 10 thì nó nhỏ, còn khi cho A2 là 15 và B2 là 30 thì nó phóng lớn lên. Nó có thể phóng to và thu nhỏ theo kích thước mình nhập vào. Mình có thể thực hiện điều đó bằng code không ạ?

Vì hình vẽ của excel có thể thay đổi được kích thước nhưng đối với một hình vẽ bên ngoài copy vào worksheet thì em không thay đổi được kích thước của nó khi em thay đổi giá trị ở ô A2 và B2 nên em dùng cách vẽ các đường thẳng rồi nối chúng lại với nhau. Anh chị nào có ý kiến hay hơn thì giúp em với ạ. Em cảm ơn anh chị rất nhiều.

 

[ndu96081631]

Mình có thể thực hiện việc thay đổi kích thước như trên đối với 1 hình vẽ được copy bên ngoài vào worksheet không hả anh? Có nghĩa là khi mình cho giá trị ô A2 là 5 và B2 là 10 thì nó nhỏ, còn khi cho A2 là 15 và B2 là 30 thì nó phóng lớn lên. Nó có thể phóng to và thu nhỏ theo kích thước mình nhập vào. Mình có thể thực hiện điều đó bằng code không ạ?

Thì trong file tôi đã làm rồi còn gì
Bạn thử thay đổi A2 và B2 sẽ thấy hình chữ nhật thay đổi kích thước theo
Ngoài ra, việc thay đổi kích thước này có thể áp dụng với mọi hình, miễn bạn xác định được tên của nó

 

[mthuvigo]

Anh ơi, em có hình tên là "picture 2" thì làm sao thay đổi kích thước của nó như giá trị nhập vào ô A2 và B2. Em không biết phải thay đổi code của anh như thế nào cho nó phù hợp, anh giúp em với.
Em đã thêm một hình tên là picture 2 vào file rồi đây ạ
http://db.tt/r7ZhXVWf

 

[ndu96081631]

Anh ơi, em có hình tên là "picture 2" thì làm sao thay đổi kích thước của nó như giá trị nhập vào ô A2 và B2.

Ví dụ thế này:

With Sheets("Sheet1").Shapes("Picture 2")
  .Left = Range("C5").Left
  .Top = Range("C5").Top
  .Width = Range("B2").Value
  .Height = Range("A2").Value
End With

Từ đó bạn cứ sửa lại cho đúng ý

 

[mthuvigo]

Với cách giải của anh ndu96081631 đã đúng ý của em. Nhưng anh ơi chỉ có mỗi Height làm thay đổi được kích thước của picture 2, còn Width thì nhập giá trị bao nhiêu cũng không thấy cái hình thay đổi. Anh giải thích chỗ này dùm em với được không ạ?

 

[ndu96081631]

Với cách giải của anh ndu96081631 đã đúng ý của em. Nhưng anh ơi chỉ có mỗi Height làm thay đổi được kích thước của picture 2, còn Width thì nhập giá trị bao nhiêu cũng không thấy cái hình thay đổi. Anh giải thích chỗ này dùm em với được không ạ?

Chắc bạn đang dùng Office 2007 hoặc 2010?
Nếu đúng vậy thì phải thêm dòng .LockAspectRatio = 0 mới xong

With Sheets("Sheet1").Shapes("Picture 2")
  [COLOR=#ff0000][B].LockAspectRatio = 0[/B][/COLOR]
  .Left = Range("C5").Left
  .Top = Range("C5").Top
  .Height = Range("A2").Value
  .Width = Range("B2").Value
End With

 

[mthuvigo]

Hay quá, cảm ơn anh ndu96081631 rất nhiều. Cảm ơn các anh chị trên diễn đàn.

Nếu A2 và B2 ở sheet 1 và hình vẽ cần thay đổi ở sheet 2 thì mình làm thế nào ạ?

 

[ndu96081631]

Nếu A2 và B2 ở sheet 1 và hình vẽ cần thay đổi ở sheet 2 thì mình làm thế nào ạ?

Ở code đầu tiên tôi có đoạn Set wks = Target.Parent chính là xác định sheet đặt hình đấy (Target.Parent tương đương với ActiveSheet)---> Giờ bạn muốn hình nằm ở sheet 2 thì cứ sửa đoạn này thôi. Chẳng hạn là Set wks = Sheets("Sheet2")

 

[mthuvigo]

Nếu sửa như code của anh trình bày thì nó cũng không thay đổi kích thước của hình bên sheet2, em qua sheet2 và viết đoạn code như thế này thì hình vẽ ở sheet2 đã thay đổi được kích thước

Private Sub Worksheet_Activate()
With Sheets("Sheet2").Shapes("Picture 28")
.LockAspectRatio = 0
.Left = Range("C5").Left
.Top = Range("C5").Top
.Height = Sheets("Sheet1").Range("A2").Value
.Width = Sheets("Sheet1").Range("B2").Value
End With
End Sub

Cảm ơn anh ndu96081631 rất nhiều. Chúc anh có thật nhiều sức khỏe.

 

[ndu96081631]

Nếu sửa như code của anh trình bày thì nó cũng không thay đổi kích thước của hình bên sheet2, em qua sheet2 và viết đoạn code như thế này thì hình vẽ ở sheet2 đã thay đổi được kích thước

Private Sub Worksheet_Activate()
With Sheets("Sheet2").Shapes("Picture 28")
.LockAspectRatio = 0
.Left = Range("C5").Left
.Top = Range("C5").Top
.Height = Sheets("Sheet1").Range("A2").Value
.Width = Sheets("Sheet1").Range("B2").Value
End With
End Sub

Cảm ơn anh ndu96081631 rất nhiều. Chúc anh có thật nhiều sức khỏe.

Sao không được chứ
Thử code hoàn chỉnh này xem:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim wks As Worksheet
  On Error Resume Next
  If Target.Address = "$A$2" Or Target.Address = "$B$2" Then
    Set wks = Sheets("Sheet2")
    With wks.Shapes("Picture 28")
      .LockAspectRatio = 0
      .Left = wks.Range("C5").Left
      .Top = wks.Range("C5").Top
      .Height = Range("A2").Value
      .Width = Range("B2").Value
    End With
  End If
End Sub

Bạn làm không được có thể liên quan đến tên sheet ---> Khi thao tác tại 2 sheet khác nhau phải ghi rõ tên sheet, nếu không Excel sẽ hiểu lầm tham chiếu chính là nằm tại ActiveSheet

 

[mthuvigo]

Anh nói đúng rồi, do em không ghi rõ là hình vẽ ở sheet2 nên nó không chịu thay đổi, nó cứ thay đổi ở sheet1 thôi.
Cảm ơn anh rất nhiều.

 

[choioi]

Rất hay, mình chưa dùng đến nhưng rất cảm ơn anh
ndu96081631

Chúc anh nhiều sức khỏe