Chèn Shape vào bảng tính theo vị trí của cell

[phuvacgach]

Dear các bác,
Em muốn xác định vị trí một điểm (Bằng Pixcel) của trên bảng tính exel thì làm như thế nào?
Trong ví dụ em đưa trong bảng tính, em muốn xác định vị trí của điểm A góc trái trên cùng của ô E8?
Em cảm ơn cả nhà.

 

[ndu96081631]

Dear các bác,
Em muốn xác định vị trí một điểm (Bằng Pixcel) của trên bảng tính exel thì làm như thế nào?
Trong ví dụ em đưa trong bảng tính, em muốn xác định vị trí của điểm A góc trái trên cùng của ô E8?
Em cảm ơn cả nhà.

Mục đích cuối cùng của bạn là để làm gì? Nói luôn đi, mất công lại lòng vòng

 

[phuvacgach]

Mục đích cuối cùng của bạn là để làm gì? Nói luôn đi, mất công lại lòng vòng

Dạ,
Em muốn vẽ biểu đồ lines freeform từ điểm này tới điểm khác theo độ rộng của cột ạ.
Em vẽ lại trong file đính kèm.

 

[ndu96081631]

Dạ,
Em muốn vẽ biểu đồ lines freeform từ điểm này tới điểm khác theo độ rộng của cột ạ.
Em vẽ lại trong file đính kèm.

Range có thuộc tính Left và Top
Range(...).Top là cạnh trên của Range(...)
Range(...).Left là cạnh trái của Range(...)
Dựa vào Top và Left mà đặt object là được rồi

 

[phuvacgach]

Sub Ve_hinh()
With ActiveSheet.Shapes.BuildFreeform(1, 289, 30)
.AddNodes 1, 1, 289, 75
.AddNodes 1, 1, 190, 82
.AddNodes 1, 1, 289, 90
.AddNodes 1, 1, 289, 120
.AddNodes 1, 1, 450, 128
.AddNodes 1, 1, 289, 135
.AddNodes 1, 1, 289, 180
.AddNodes 1, 1, 140, 188
.AddNodes 1, 1, 289, 195
.ConvertToShape
End With
End Sub

Dear anh,
Em muốn xác định điểm pixcel để áp dụng vào vẽ lines theo như code kiểu như trên.
Làm vậy em cần phải xác định được tọa độ 1 điểm theo pixcel?
Hình vẽ đồ thị chi tiết thì liên quan tới link bên dưới em đang hỏi.

http://www.giaiphapexcel.com/forum/showthread.php?76696-T%E1%BA%A1o-Shape-Line-trong-VBA
Em cảm ơn.

 

[ndu96081631]

Sub Ve_hinh()
With ActiveSheet.Shapes.BuildFreeform(1, 289, 30)
.AddNodes 1, 1, 289, 75
.AddNodes 1, 1, 190, 82
.AddNodes 1, 1, 289, 90
.AddNodes 1, 1, 289, 120
.AddNodes 1, 1, 450, 128
.AddNodes 1, 1, 289, 135
.AddNodes 1, 1, 289, 180
.AddNodes 1, 1, 140, 188
.AddNodes 1, 1, 289, 195
.ConvertToShape
End With
End Sub

Dear anh,
Em muốn xác định điểm pixcel để áp dụng vào vẽ lines theo như code kiểu như trên.
Làm vậy em cần phải xác định được tọa độ 1 điểm theo pixcel?
Hình vẽ đồ thị chi tiết thì liên quan tới link bên dưới em đang hỏi.

http://www.giaiphapexcel.com/forum/showthread.php?76696-Tạo-Shape-Line-trong-VBA
Em cảm ơn.

Để đơn giản hóa vấn đề tôi không dùng Freeform mà vẽ từng line rồi nối lại. Các line này sẽ dựa trên địa chỉ cell cụ thể
1> Function để vẽ lines:

Function DrawLines(ParamArray rCells()) As Shape
  Dim wks As Worksheet, i As Long, Arr()
  On Error GoTo ExitFunc
  If IsArray(rCells) Then
    Set wks = rCells(0).Parent
    ReDim Arr(1 To UBound(rCells))
    For i = 1 To UBound(rCells)
      Arr(i) = wks.Shapes.AddConnector(1, rCells(i - 1).Left, rCells(i - 1).Top, rCells(i).Left, rCells(i).Top).Name
    Next
    Set DrawLines = wks.Shapes.Range(Arr).Group
  End If
ExitFunc:
End Function

2> Code chính của bạn
Ví dụ bạn muốn vẽ các đường thằng đi qua Top, Left của các cell G3, G5, E6, G7, G8, I9, G10, G12, D13, G14

Sub Draw()
  DrawLines [G3], [G5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14]
End Sub

Hàm DrawLines trả về kết quả là 1 Shape, vì thế sau khi vẽ xong, bạn hoàn toàn có thể format nó theo ý mình
Ví dụ:

Sub Draw()
  With DrawLines([G3], [G5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14])
    .Name = "Tia sét"
    .Line.ForeColor.RGB = vbRed
    .Line.Weight = 3
  End With
End Sub

 

[phuvacgach]

Sub Draw()
Dim a()
ReDim a(1 To 3)
a(1) = [g3]
a(2) = [g5]
a(3) = [E6]
'With DrawLines([g3], [g5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14])
With DrawLines(a())
.Name = "Tia sét"
.Line.ForeColor.RGB = vbRed
.Line.Weight = 3
End With
End Sub

Dear anh,
Em cũng không rõ lắm về aRray nên có một câu hỏi nhờ anh giúp.
Em muốn gộp tất cả các Cells trên thành một mảng và cho vào funtions của anh.
Muốn như vậy thì cần phải sửa Funtion như thế nào không?
Em cảm ơn.

 

[ndu96081631]

Sub Draw()
Dim a()
ReDim a(1 To 3)
a(1) = [g3]
a(2) = [g5]
a(3) = [E6]
'With DrawLines([g3], [g5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14])
With DrawLines(a())
.Name = "Tia sét"
.Line.ForeColor.RGB = vbRed
.Line.Weight = 3
End With
End Sub

Dear anh,
Em cũng không rõ lắm về aRray nên có một câu hỏi nhờ anh giúp.
Em muốn gộp tất cả các Cells trên thành một mảng và cho vào funtions của anh.
Muốn như vậy thì cần phải sửa Funtion như thế nào không?
Em cảm ơn.

Vì mỗi phần tử của mảng là 1 Range nên câu lệnh a(1) = [g3] là sai hoàn toàn
Phải vầy:

Set a(1) = [g3]
Set a(2) = [g5]
Set a(3) = [E6]

Đồng thời sửa lại hàm DrawLines

Function DrawLines(ByVal aCells) As Shape
  Dim wks As Worksheet
  Dim i As Long, n As Long
  Dim rCel1, rCel2, Arr()
  On Error GoTo ExitFunc
  If IsArray(aCells) Then
    If TypeOf aCells(LBound(aCells)) Is Range Then
      Set rCel1 = aCells(LBound(aCells))
      Set wks = rCel1.Parent
    End If
    For i = LBound(aCells) + 1 To UBound(aCells)
      If TypeOf aCells(i) Is Range Then
        Set rCel2 = aCells(i)
        n = n + 1
        ReDim Preserve Arr(1 To n)
        Arr(n) = wks.Shapes.AddConnector(1, rCel1.Left, rCel1.Top, rCel2.Left, rCel2.Top).Name
        Set rCel1 = aCells(i)
      End If
    Next
    If n > 1 Then
      Set DrawLines = wks.Shapes.Range(Arr).Group
    Else
      Set DrawLines = wks.Shapes(Arr(UBound(Arr)))
    End If
  End If
ExitFunc:
End Function

Còn code của bạn thì sửa thành:

Sub Draw2()
  Dim a()
  ReDim a(1 To 3)
[COLOR=#ff0000]  Set a(1) = [G3]
  Set a(2) = [G5]
  Set a(3) = [E6][/COLOR]
  With DrawLines(a())
    .Name = "Tia sét"
    .Line.ForeColor.RGB = vbRed
    .Line.Weight = 3
  End With
End Sub

Hoặc:

Sub Draw2()
  Dim a
  a = Array([G3], [G5], [E6]) 
  With DrawLines(a)
    .Name = "Tia sét"
    .Line.ForeColor.RGB = vbRed
    .Line.Weight = 3
  End With
End Sub

-----------------------
Bạn cũng có thể sửa dòng:
wks.Shapes.AddConnector(1, rCel1.Left, rCel1.Top, rCel2.Left, rCel2.Top).Name
Thành:
wks.Shapes.AddLine(rCel1.Left, rCel1.Top, rCel2.Left, rCel2.Top).Name
Cho gọn

 

[Truongan1996]

Để đơn giản hóa vấn đề tôi không dùng Freeform mà vẽ từng line rồi nối lại. Các line này sẽ dựa trên địa chỉ cell cụ thể
1> Function để vẽ lines:

Function DrawLines(ParamArray rCells()) As Shape
  Dim wks As Worksheet, i As Long, Arr()
  On Error GoTo ExitFunc
  If IsArray(rCells) Then
    Set wks = rCells(0).Parent
    ReDim Arr(1 To UBound(rCells))
    For i = 1 To UBound(rCells)
      Arr(i) = wks.Shapes.AddConnector(1, rCells(i - 1).Left, rCells(i - 1).Top, rCells(i).Left, rCells(i).Top).Name
    Next
    Set DrawLines = wks.Shapes.Range(Arr).Group
  End If
ExitFunc:
End Function

2> Code chính của bạn
Ví dụ bạn muốn vẽ các đường thằng đi qua Top, Left của các cell G3, G5, E6, G7, G8, I9, G10, G12, D13, G14

Sub Draw()
  DrawLines [G3], [G5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14]
End Sub

Hàm DrawLines trả về kết quả là 1 Shape, vì thế sau khi vẽ xong, bạn hoàn toàn có thể format nó theo ý mình
Ví dụ:

Sub Draw()
  With DrawLines([G3], [G5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14])
    .Name = "Tia sét"
    .Line.ForeColor.RGB = vbRed
    .Line.Weight = 3
  End With
End Sub

Chào anh !
Em co đoạn này để vẽ hình oval, nhưng mà các tọa độ để hình xuất hiện thì không cố định.
Có cách nào xác định toạ độ không vậy
ActiveSheet.Shapes.AddShape(msoShapeOval, 242.25, 30, 74.24, 30).Select

Cảm ơn anh !

 

[Bluestar092011]

Chào anh !
Em co đoạn này để vẽ hình oval, nhưng mà các tọa độ để hình xuất hiện thì không cố định.
Có cách nào xác định toạ độ không vậy
ActiveSheet.Shapes.AddShape(msoShapeOval, 242.25, 30, 74.24, 30).Select

Cảm ơn anh !

Thử code này xem có đúng ý chưa.

Sub addshapetocell(Rng As Range, W As Double, H As Double)
    Dim clLeft As Double
    Dim clTop As Double
    Dim shpOval As Shape
    clLeft = Rng.Left
    clTop = Rng.Top
    Set shpOval = ActiveSheet.Shapes.AddShape(msoShapeOval, clLeft, clTop, W, H)
End Sub

Public Sub Test()
    addshapetocell Selection, 40, 10
End Sub