Shapes - Shapes Line bằng VBA

Liên hệ QC

A Đặng

Thành viên mới
Tham gia
18/12/18
Bài viết
37
Được thích
2
Giới tính
Nam
Xin chào các Thầy, các Anh Chị trong GPE.
em có đọc qua một số bài viết về Shapes line trong diễn đàn. nhưng vẫn chưa đủ kiến thức để giải quyết vấn đề.
do vậy em có vấn đề đặt ra được lưu trong file đính kèm, mong các thầy, anh chị trong GPE hỗ trợ giùm.
Xin cám ơn !
 

File đính kèm

  • file - Line.xlsm
    10.3 KB · Đọc: 26
Xin chào các Thầy, các Anh Chị trong GPE.
em có đọc qua một số bài viết về Shapes line trong diễn đàn. nhưng vẫn chưa đủ kiến thức để giải quyết vấn đề.
do vậy em có vấn đề đặt ra được lưu trong file đính kèm, mong các thầy, anh chị trong GPE hỗ trợ giùm.
Xin cám ơn !
Bạn thử Code này xem
PHP:
Sub Addshapetocell()
    Dim ws As Worksheet, s As Shape, eRng As Range
    Dim BeginX As Double, BeginY As Double, EndX As Double, EndY As Double
    Dim Er As Long, Ec As Long
Set ws = ActiveSheet
Set eRng = ws.Range("B11")
Application.ScreenUpdating = False
For Each s In ws.Shapes
    If Not (s.Type = msoOLEControlObject Or s.Type = msoFormControl) Then s.Delete
Next s
With ws
    Er = .Range("D65535").End(3).Row:    Ec = eRng.Row - 1
    For j = 2 To 7
        BeginX = .Range(Cells(Er, 1), .Cells(Er, j)).Width
        BeginY = .Range(Cells(1, j), .Cells(Er, j)).Height
        EndX = .Range(.Cells(Ec, 1), .Cells(Ec, j - 1)).Width
        EndY = .Range(.Cells(1, j - 1), .Cells(Ec, j - 1)).Height
        Set s = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, BeginX, BeginY, EndX, EndY)
        s.Name = "S_" & j
        ActiveSheet.Shapes.Range(Array(s.Name)).Select
        With Selection.ShapeRange.Line
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorText1
        End With
    Next j
End With
Set s = Nothing
Range("A1").Select
Application.ScreenUpdating = True
End Sub
 
Bạn thử Code này xem
PHP:
Sub Addshapetocell()
    Dim ws As Worksheet, s As Shape, eRng As Range
    Dim BeginX As Double, BeginY As Double, EndX As Double, EndY As Double
    Dim Er As Long, Ec As Long
Set ws = ActiveSheet
Set eRng = ws.Range("B11")
Application.ScreenUpdating = False
For Each s In ws.Shapes
    If Not (s.Type = msoOLEControlObject Or s.Type = msoFormControl) Then s.Delete
Next s
With ws
    Er = .Range("D65535").End(3).Row:    Ec = eRng.Row - 1
    For j = 2 To 7
        BeginX = .Range(Cells(Er, 1), .Cells(Er, j)).Width
        BeginY = .Range(Cells(1, j), .Cells(Er, j)).Height
        EndX = .Range(.Cells(Ec, 1), .Cells(Ec, j - 1)).Width
        EndY = .Range(.Cells(1, j - 1), .Cells(Ec, j - 1)).Height
        Set s = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, BeginX, BeginY, EndX, EndY)
        s.Name = "S_" & j
        ActiveSheet.Shapes.Range(Array(s.Name)).Select
        With Selection.ShapeRange.Line
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorText1
        End With
    Next j
End With
Set s = Nothing
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Xin cám ơn PacificPR rất nhiều. code hoạt động rất tốt.
Chúc bạn 1 ngày làm việc vui !
 
Dear PacificPR .
Hôm bữa bạn có giúp mình về code tạo đường line, mình vẫn áp dụng được vào một số trường hợp. Tuy nhiên lại không được hiểu rõ lắm về câu lệnh tạo đường line, hay những yếu tố như BeginX, BeginY, EndX,EndY nó có tác dụng như thế nào?
Bạn có thể giải thích giúp mình được không ? Hay có tài liệu nào về nó ?
Cám ơn nhiều !
Chúc buổi tối vui vẻ !
Bài đã được tự động gộp:

Bạn thử Code này xem
PHP:
Sub Addshapetocell()
    Dim ws As Worksheet, s As Shape, eRng As Range
    Dim BeginX As Double, BeginY As Double, EndX As Double, EndY As Double
    Dim Er As Long, Ec As Long
Set ws = ActiveSheet
Set eRng = ws.Range("B11")
Application.ScreenUpdating = False
For Each s In ws.Shapes
    If Not (s.Type = msoOLEControlObject Or s.Type = msoFormControl) Then s.Delete
Next s
With ws
    Er = .Range("D65535").End(3).Row:    Ec = eRng.Row - 1
    For j = 2 To 7
        BeginX = .Range(Cells(Er, 1), .Cells(Er, j)).Width
        BeginY = .Range(Cells(1, j), .Cells(Er, j)).Height
        EndX = .Range(.Cells(Ec, 1), .Cells(Ec, j - 1)).Width
        EndY = .Range(.Cells(1, j - 1), .Cells(Ec, j - 1)).Height
        Set s = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, BeginX, BeginY, EndX, EndY)
        s.Name = "S_" & j
        ActiveSheet.Shapes.Range(Array(s.Name)).Select
        With Selection.ShapeRange.Line
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorText1
        End With
    Next j
End With
Set s = Nothing
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Dear PacificPR .
Hôm bữa bạn có giúp mình về code tạo đường line, mình vẫn áp dụng được vào một số trường hợp. Tuy nhiên lại không được hiểu rõ lắm về câu lệnh tạo đường line, hay những yếu tố như BeginX, BeginY, EndX,EndY nó có tác dụng như thế nào?
Bạn có thể giải thích giúp mình được không ? Hay có tài liệu nào về nó ?
Cám ơn nhiều !
Chúc buổi tối vui vẻ !
 
@PacificPR
Sao lại là:
PHP:
Set s = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, BeginX, BeginY, EndX, EndY)
s.Name = "S_" & j
ActiveSheet.Shapes.Range(Array(s.Name)).Select
With Selection.ShapeRange.Line
Sao không như thế này để gọn hơn:
PHP:
With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, BeginX, BeginY, EndX, EndY).Line
     '.......
     '.......
      .Parent.Name = "S_" & j



Function AddConnector(Type As MsoConnectorType, BeginX As Single, BeginY As Single, EndX As Single, EndY As Single) As Shape

MsoConnectorType gồm 4 kiểu:
1. msoConnectorTypeMixed = -2 (&HFFFFFFFE)
2. msoConnectorStraight = 1
3. msoConnectorElbow = 2
4. msoConnectorCurve = 3


BeginX: Khoảng cách Tính từ Điểm đầu của Shape đến Giới hạn trái của Sheet
EndX: Khoảng cách Tính từ Điểm cuối của Shape đến Giới hạn trái của Sheet
BeginY: Khoảng cách Tính từ Điểm đầu của Shape đến Giới hạn trên của Sheet
EndY: Khoảng cách Tính từ Điểm cuối của Shape đến Giới hạn trên của Sheet
 
Lần chỉnh sửa cuối:
@PacificPR
Sao lại là:
PHP:
Set s = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, BeginX, BeginY, EndX, EndY)
s.Name = "S_" & j
ActiveSheet.Shapes.Range(Array(s.Name)).Select
With Selection.ShapeRange.Line
Sao không như thế này để gọn hơn:
PHP:
With ActiveSheet.Shapes.AddConnector(msoConnectorStraight, BeginX, BeginY, EndX, EndY).Line




Function AddConnector(Type As MsoConnectorType, BeginX As Single, BeginY As Single, EndX As Single, EndY As Single) As Shape

MsoConnectorType gồm 4 kiểu:
1. msoConnectorTypeMixed = -2 (&HFFFFFFFE)
2. msoConnectorStraight = 1
3. msoConnectorElbow = 2
4. msoConnectorCurve = 3


BeginX: Khoảng cách Tính từ Điểm đầu của Shape đến Giới hạn trái của Sheet
EndX: Khoảng cách Tính từ Điểm cuối của Shape đến Giới hạn trái của Sheet
BeginY: Khoảng cách Tính từ Điểm đầu của Shape đến Giới hạn trên của Sheet
EndY: Khoảng cách Tính từ Điểm cuối của Shape đến Giới hạn trên của Sheet
4 kiểu mso có khác gì nhau không ạ?
 
Web KT
Back
Top Bottom