Xin trợ giúp: Code VBA vẽ đường tiến độ trong excel

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
M

maithangbs

Thành viên mới
Tham gia
10/5/13
Bài viết
8
Được thích
0
Xin chào các bác!
Em có một vấn đề xin nhờ các cao thủ trợ giúp
File Excel lập kế hoạch, có vẽ line tiến độ (như file em gửi kèm), hiện tại em chỉ dùng hàm If đề kiểm tra nếu ngày tháng trong cột n đến cột AU, trong khoảng từ ngày I và ngày K thì vẽ đường đôi, hoặc đường đơn nét đứt
Nhưng tiến độ như này, nhìn hơi xấu, mặc dù đạt mục đích mình
Xin các bác giúp cho đoạn code VBA để vẽ đường liền (shape) thay đoạn đường đứt kia\
Cảm ơn các bác nhiều
 

File đính kèm

  • Bang Tien do.xlsx
    140.3 KB · Đọc: 23
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Thử code này nhé . . .
Nhấn thử vào nút "Updated", mỗi khi thay đổi thông tin

PHP: 
Option Explicit
Sub tiendo()
Dim lr&, j&, ce As Range, ngaybd As Double, ngaykt As Double, sh As Shape
Dim ce1Left, ce1Top, ce2Left, ce2Top
lr = Cells(Rows.Count, "I").End(xlUp).Row
For Each ce In Range("C11:C" & lr)
    ngaybd = ce.Offset(, 6).Value2: ngaykt = ce.Offset(, 8).Value2
    If ngaybd > Range("AU9").Value Or ngaykt < Range("N9").Value Then Exit Sub
    If ngaykt > Range("AU9").Value Then ngaykt = Range("AU9").Value
    If ngaybd < Range("N9").Value Then ngaybd = Range("N9").Value
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Row = ce.Row Then
           sh.Delete
        End If
    Next
    For j = 14 To 47
        If Cells(9, j).Value = ngaybd Then
            ce1Left = Cells(ce.Row, j).Left: ce1Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
        End If
        If Cells(9, j).Value = ngaykt Then
            ce2Left = Cells(ce.Row, j).Left + Cells(ce.Row, j).Width: ce2Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
            Exit For
        End If
    Next
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, ce1Left, ce1Top, ce2Left, ce2Top).Select
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = IIf(ce <> "", 2, 6)
        .ForeColor.RGB = IIf(ce <> "", RGB(0, 112, 192), RGB(255, 155, 155))
    End With
Next
End Sub
 

File đính kèm

  • Bang Tien do.xlsm
    149.1 KB · Đọc: 46
Upvote 0
Tôi không thích cái danh xưng đánh đồng là "cao thủ" cho nên tôi không trả lời thẳng với thớt.
Bài này viết để chỉ dẫn cho các bạn:
1. Cũng không thích từ này như tôi
2. Không bị cái hào nhoáng của VBA làm mờ mắt.

Để vẽ đường không đứt, người ta dùng emdash (dầu trừ dài bằng một ký tự viết thường, code CHAR của nó là 151, ciode UNICHAR là 9472
Để vẽ đường đôi không đứt, người ta dùng dấu headbox, code CHAR của nó là 205 (khong dùng được trong Exce;l), code UNICHAR là 9552, dùng được trong Excel.

Đây là kết quả của các code trên, dùng Rept(..., 2) để tăng lên thành chuỗi 2 ký tự:
1696851613512.png
 
Upvote 0
Sao bạn không thử dùng condition formating sẽ dễ nhận diện hơn
kiểu như thế này:
1696865787913.png
 
Lần chỉnh sửa cuối:
Upvote 0
mraleno đã viết:
Sao bạn không thử dùng condition formating sẽ dễ nhận diện hơn
kiểu như thế này:
View attachment 295552
Nhấp chuột vào đây để mở rộng...
Cái này thì em làm rồi, nhưng với những dòng rộng do nội dung công việc nhiều, thì ô to lắm.
VetMini đã viết:
Tôi không thích cái danh xưng đánh đồng là "cao thủ" cho nên tôi không trả lời thẳng với thớt.
Bài này viết để chỉ dẫn cho các bạn:
1. Cũng không thích từ này như tôi
2. Không bị cái hào nhoáng của VBA làm mờ mắt.

Để vẽ đường không đứt, người ta dùng emdash (dầu trừ dài bằng một ký tự viết thường, code CHAR của nó là 151, ciode UNICHAR là 9472
Để vẽ đường đôi không đứt, người ta dùng dấu headbox, code CHAR của nó là 205 (khong dùng được trong Exce;l), code UNICHAR là 9552, dùng được trong Excel.

Đây là kết quả của các code trên, dùng Rept(..., 2) để tăng lên thành chuỗi 2 ký tự:
View attachment 295547
Nhấp chuột vào đây để mở rộng...
Vẫn bị đứt quãng bác ạ
bebo021999 đã viết:
Thử code này nhé . . .
Nhấn thử vào nút "Updated", mỗi khi thay đổi thông tin

PHP: 
Option Explicit
Sub tiendo()
Dim lr&, j&, ce As Range, ngaybd As Double, ngaykt As Double, sh As Shape
Dim ce1Left, ce1Top, ce2Left, ce2Top
lr = Cells(Rows.Count, "I").End(xlUp).Row
For Each ce In Range("C11:C" & lr)
    ngaybd = ce.Offset(, 6).Value2: ngaykt = ce.Offset(, 8).Value2
    If ngaybd > Range("AU9").Value Or ngaykt < Range("N9").Value Then Exit Sub
    If ngaykt > Range("AU9").Value Then ngaykt = Range("AU9").Value
    If ngaybd < Range("N9").Value Then ngaybd = Range("N9").Value
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Row = ce.Row Then
           sh.Delete
        End If
    Next
    For j = 14 To 47
        If Cells(9, j).Value = ngaybd Then
            ce1Left = Cells(ce.Row, j).Left: ce1Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
        End If
        If Cells(9, j).Value = ngaykt Then
            ce2Left = Cells(ce.Row, j).Left + Cells(ce.Row, j).Width: ce2Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
            Exit For
        End If
    Next
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, ce1Left, ce1Top, ce2Left, ce2Top).Select
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = IIf(ce <> "", 2, 6)
        .ForeColor.RGB = IIf(ce <> "", RGB(0, 112, 192), RGB(255, 155, 155))
    End With
Next
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bác nhé, nhưng em thử thay đổi ngày và click update thì nó chạy chưa đúng, đương nhiên đã enable macro rồi
 
Upvote 0
maithangbs đã viết:
Cảm ơn bác nhé, nhưng em thử thay đổi ngày và click update thì nó chạy chưa đúng, đương nhiên đã enable macro rồi
Nhấp chuột vào đây để mở rộng...
Bạn cho ví dụ cụ thể dòng nào, ngày thay đổi là ngày nào, kết quả sai ra sao nhé. Post file với kết quả sai lên nhé.
 
Upvote 0
bebo021999 đã viết:
Thử code này nhé . . .
Nhấn thử vào nút "Updated", mỗi khi thay đổi thông tin

PHP: 
Option Explicit
Sub tiendo()
Dim lr&, j&, ce As Range, ngaybd As Double, ngaykt As Double, sh As Shape
Dim ce1Left, ce1Top, ce2Left, ce2Top
lr = Cells(Rows.Count, "I").End(xlUp).Row
For Each ce In Range("C11:C" & lr)
    ngaybd = ce.Offset(, 6).Value2: ngaykt = ce.Offset(, 8).Value2
    If ngaybd > Range("AU9").Value Or ngaykt < Range("N9").Value Then Exit Sub
    If ngaykt > Range("AU9").Value Then ngaykt = Range("AU9").Value
    If ngaybd < Range("N9").Value Then ngaybd = Range("N9").Value
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Row = ce.Row Then
           sh.Delete
        End If
    Next
    For j = 14 To 47
        If Cells(9, j).Value = ngaybd Then
            ce1Left = Cells(ce.Row, j).Left: ce1Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
        End If
        If Cells(9, j).Value = ngaykt Then
            ce2Left = Cells(ce.Row, j).Left + Cells(ce.Row, j).Width: ce2Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
            Exit For
        End If
    Next
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, ce1Left, ce1Top, ce2Left, ce2Top).Select
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = IIf(ce <> "", 2, 6)
        .ForeColor.RGB = IIf(ce <> "", RGB(0, 112, 192), RGB(255, 155, 155))
    End With
Next
End Sub
Nhấp chuột vào đây để mở rộng...
Ồ cái món này lập tiến độ hay hơn cách tô màu dòng giữa (1 công việc cần 3 dòng).
Em hỏi cái, giờ em muốn thoát khỏi cái shape cuối cùng đang được lựa chọn để trở về bảng tính thì thêm dòng code sao bác nhỉ?
Em hay dùng mũi tên để qua lại làm đoạn tiến độ nó bị trôi theo.

1696934761992.png
 
Upvote 0
bebo021999 đã viết:
Bạn cho ví dụ cụ thể dòng nào, ngày thay đổi là ngày nào, kết quả sai ra sao nhé. Post file với kết quả sai lên nhé.
Nhấp chuột vào đây để mở rộng...
À, sorry bác, code vẫn chạy bình thường nhé bác, hôm qua em xóa mất dữ liệu ở ô I11 và k11, nên marco không chạy
Cảm ơn bác nhiều, nhưng nó có cái nút update thì hơi xấu nhỉ, đề em mò tiếp chỗ chạy marco mỗi khi vùng dữ liệu thay đổi
 
Upvote 0
Em đã xóa được cái button Update, đề mỗi khi thay đổi ngày tháng thì biểu đồ tự cập nhật rồi
Nhưng có một vấn đề, khi em thêm các mục con 2.5, 2.6, 2.7 như file gửi kèm, thì nó lại vẽ dòng khổ to (thay vì dòng nhỏ)
(Phân biệt giữa vẽ dòng to và nhỏ là dữ liệu ở cột J, nếu có dữ liệu thì vẽ nhỏ, không có dữ liệu thì vẽ to)
Bác @bebo021999 và các bác xem giúp em nhé
Bác @cantl ý bác cũng rất hay, tránh trường hợp chạm nhầm phím
 

File đính kèm

  • Bang Tien do.xlsm
    30.1 KB · Đọc: 3
Upvote 0
maithangbs đã viết:
Em đã xóa được cái button Update, đề mỗi khi thay đổi ngày tháng thì biểu đồ tự cập nhật rồi
Nhưng có một vấn đề, khi em thêm các mục con 2.5, 2.6, 2.7 như file gửi kèm, thì nó lại vẽ dòng khổ to (thay vì dòng nhỏ)
(Phân biệt giữa vẽ dòng to và nhỏ là dữ liệu ở cột J, nếu có dữ liệu thì vẽ nhỏ, không có dữ liệu thì vẽ to)
Bác @bebo021999 và các bác xem giúp em nhé
Bác @cantl ý bác cũng rất hay, tránh trường hợp chạm nhầm phím
Nhấp chuột vào đây để mở rộng...
chỉnh 1 chút:
Chọn sheet, ô target
PHP: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("I11:K100")) Is Nothing Then
    Call tiendo
    Target.Select ' sau khu sub tiendo chay xong thi chon target tro lai
End If
End Sub

Đổi ô "ce" từ cột C qua J
PHP: 
Option Explicit
Sub tiendo()
Dim lr&, j&, ce As Range, ngaybd As Double, ngaykt As Double, sh As Shape
Dim ce1Left, ce1Top, ce2Left, ce2Top
Application.ScreenUpdating = False ' tat man hinh nhap nhay
lr = Cells(Rows.Count, "I").End(xlUp).Row
For Each ce In Range("J11:J" & lr) ' thay doi: tu cot C sang cot J
    ngaybd = ce.Offset(, -1).Value2: ngaykt = ce.Offset(, 1).Value2
    If ngaykt > Range("AU9").Value Then ngaykt = Range("AU9").Value
    If ngaybd < Range("N9").Value Then ngaybd = Range("N9").Value
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Row = ce.Row Then
           sh.Delete
        End If
    Next
    If ngaybd > Range("AU9").Value Or ngaykt < Range("N9").Value Then Exit Sub
    For j = 14 To 47
        If Cells(9, j).Value = ngaybd Then
            ce1Left = Cells(ce.Row, j).Left: ce1Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
        End If
        If Cells(9, j).Value = ngaykt Then
            ce2Left = Cells(ce.Row, j).Left + Cells(ce.Row, j).Width: ce2Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
            Exit For
        End If
    Next
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, ce1Left, ce1Top, ce2Left, ce2Top).Select
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = IIf(ce <> "", 2, 6)
        .ForeColor.RGB = IIf(ce <> "", RGB(0, 112, 192), RGB(255, 155, 155))
    End With
Next
Application.ScreenUpdating = True ' bat cap nhat man hinh tro lai
End Sub
 

File đính kèm

  • Bang Tien do (1).xlsm
    30.2 KB · Đọc: 26
Upvote 0
bebo021999 đã viết:
chỉnh 1 chút:
Chọn sheet, ô target
PHP: 
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("I11:K100")) Is Nothing Then
    Call tiendo
    Target.Select ' sau khu sub tiendo chay xong thi chon target tro lai
End If
End Sub

Đổi ô "ce" từ cột C qua J
PHP: 
Option Explicit
Sub tiendo()
Dim lr&, j&, ce As Range, ngaybd As Double, ngaykt As Double, sh As Shape
Dim ce1Left, ce1Top, ce2Left, ce2Top
Application.ScreenUpdating = False ' tat man hinh nhap nhay
lr = Cells(Rows.Count, "I").End(xlUp).Row
For Each ce In Range("J11:J" & lr) ' thay doi: tu cot C sang cot J
    ngaybd = ce.Offset(, -1).Value2: ngaykt = ce.Offset(, 1).Value2
    If ngaykt > Range("AU9").Value Then ngaykt = Range("AU9").Value
    If ngaybd < Range("N9").Value Then ngaybd = Range("N9").Value
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Row = ce.Row Then
           sh.Delete
        End If
    Next
    If ngaybd > Range("AU9").Value Or ngaykt < Range("N9").Value Then Exit Sub
    For j = 14 To 47
        If Cells(9, j).Value = ngaybd Then
            ce1Left = Cells(ce.Row, j).Left: ce1Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
        End If
        If Cells(9, j).Value = ngaykt Then
            ce2Left = Cells(ce.Row, j).Left + Cells(ce.Row, j).Width: ce2Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
            Exit For
        End If
    Next
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, ce1Left, ce1Top, ce2Left, ce2Top).Select
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = IIf(ce <> "", 2, 6)
        .ForeColor.RGB = IIf(ce <> "", RGB(0, 112, 192), RGB(255, 155, 155))
    End With
Next
Application.ScreenUpdating = True ' bat cap nhat man hinh tro lai
End Sub
Nhấp chuột vào đây để mở rộng...
Hi, ngại quá bác ạ, nhưng hình như bác lại chữa lợn lành thành lợn què :) rồi
File giờ không update khi thay đổi ngày luôn, và thậm chí hàm Min, Max còn chạy sai luôn
 

File đính kèm

  • Bang Tien do 1.xlsm
    30.6 KB · Đọc: 4
Upvote 0
maithangbs đã viết:
Hi, ngại quá bác ạ, nhưng hình như bác lại chữa lợn lành thành lợn què :) rồi
Nhấp chuột vào đây để mở rộng...
Lỡ giúp rồi nên mình giúp luôn, đúng ra trường hợp này thì mình sẽ không tiếp tục giúp nữa đâu nhé:
Chỗ này:
PHP: 
If ngaybd > Range("AU9").Value Or ngaykt < Range("N9").Value Then Exit Sub
SỬa thành
PHP: 
If ngaybd > Range("AU9").Value Or ngaykt < Range("N9").Value Then GoTo z

PHP: 
Option Explicit
Sub tiendo()
Dim lr&, j&, ce As Range, ngaybd As Double, ngaykt As Double, sh As Shape
Dim ce1Left, ce1Top, ce2Left, ce2Top
Application.ScreenUpdating = False ' tat man hinh nhap nhay
lr = Cells(Rows.Count, "I").End(xlUp).Row
For Each ce In Range("J11:J" & lr) ' thay doi: tu cot C sang cot J
    ngaybd = ce.Offset(, -1).Value2: ngaykt = ce.Offset(, 1).Value2
    If ngaykt > Range("AU9").Value Then ngaykt = Range("AU9").Value
    If ngaybd < Range("N9").Value Then ngaybd = Range("N9").Value
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Row = ce.Row Then
           sh.Delete
        End If
    Next
    If ngaybd > Range("AU9").Value Or ngaykt < Range("N9").Value Then GoTo z
    For j = 14 To 47
        If Cells(9, j).Value = ngaybd Then
            ce1Left = Cells(ce.Row, j).Left: ce1Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
        End If
        If Cells(9, j).Value = ngaykt Then
            ce2Left = Cells(ce.Row, j).Left + Cells(ce.Row, j).Width: ce2Top = Cells(ce.Row, j).Top + Cells(ce.Row, j).Height / 2
            Exit For
        End If
    Next
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, ce1Left, ce1Top, ce2Left, ce2Top).Select
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = IIf(ce <> "", 2, 6)
        .ForeColor.RGB = IIf(ce <> "", RGB(0, 112, 192), RGB(255, 155, 155))
    End With
z:
Next
Application.ScreenUpdating = True ' bat cap nhat man hinh tro lai
End Sub
 
Upvote 0
Thì đúng là đang chạy bình thường, sửa lại chạy lỗi thì câu đó đúng văn cảnh rồi. Chỉ có đều đừng nên trích dẫn câu cụt như các báo lá cải trên mạng, giật "tít", dẫn dắt suy nghĩ người đọc theo hướng khác..
 
Lần chỉnh sửa cuối:
Upvote 0
Em up lại kết quả sau khi chỉnh sửa lại một chút để bác nào cần thì tải về tham khảo. Em có chỉnh sửa lại chỗ nếu mình thay đổi ngày/tháng/năm trên Control box thì marco Tiendo sẽ tự chay lại
 

File đính kèm

  • Bang Tien do 1.xlsm
    30.5 KB · Đọc: 20
Upvote 0
Thay vì vẽ một đống object lên sheet tôi sẽ dùng các ký tự ở bài #3. Thử với số dòng lên đến hàng nghìn sẽ thấy khác biệt.

1697110520760.png
 
Upvote 0
Bảng tiến độ này sao không dùng MS Project nhỉ?
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

H
  • Question
Xóa toàn bộ các dòng giống nhau ở 1 cột
Trả lời
0
Đọc
1
hadoan-pap
H
Hai Lúa Miền Tây
  • Question
Hàm chuyển dữ liệu từ cột sang dòng (Hàm melt + wide_to_long của Python trong Excel)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
8
Đọc
417
Duy Tùng 9x
Duy Tùng 9x
ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
7 8 9
Trả lời
163
Đọc
8K
trannguyen197
T
Manhhung90
Liệt kê các ngày cộng dồn mong muốn vào 1 ô. Nhờ mọi người giúp mình ạ.
2 3 4
Trả lời
61
Đọc
685
huuthang_bd
huuthang_bd
vova2209
  • Question
Tìm địa chỉ ô với 2đk và chuyển thành links
Trả lời
12
Đọc
190
vova2209
vova2209
tvcneo
  • Question
Nhờ Anh Chị Em giúp mình cách để tạo macro giống như trong file này
Trả lời
17
Đọc
214
huuthang_bd
huuthang_bd
T
Có phải lỗi Excel?
Trả lời
8
Đọc
9K
dinhthang8709
D
T
Công thức lấy dữ liệu
Trả lời
3
Đọc
110
HUONGHCKT
H
S
  • Question
Nhờ anh chị giúp em hàm ngẫu nhiên với tổng là 1 số
Trả lời
6
Đọc
143
SA_DQ
SA_DQ
O
  • Question
Tìm số thứ tự của sheet trong workbook có nhiều sheets
Trả lời
10
Đọc
3K
Hoàng Tuấn 868
H
L
Tự động nhảy số tham chiếu khi sang sheet mới
Trả lời
5
Đọc
5K
Romantic92
R
TieuLong2708
Danh sách lịch cắt người trực
Trả lời
0
Đọc
36
TieuLong2708
TieuLong2708
C
  • Question
Xin giúp đỡ Code kiểm tra và copy dữ liệu từ sheet 1 sang sheet 2
2
Trả lời
21
Đọc
622
conan1
C
H
  • Question
Mong giúp code chuyển file xls sang xlsx hàng loạt và không lỗi số liệu
Trả lời
16
Đọc
366
Hoàng Tuấn 868
H
jenny12345
tổng hợp dữ liệu theo tháng
Trả lời
10
Đọc
241
Hoàng Tuấn 868
H
S
Trợ giúp công thức lấy dữ liệu
Trả lời
7
Đọc
132
Hoàng Tuấn 868
H
M
Không gõ được tiếng Việt trên Excel
Trả lời
4
Đọc
116
MKC
M
H
Có thể mở file Excel mới sẽ Zoom mặc định 150% không?
Trả lời
3
Đọc
145
hieug126
H
hieuxd
Tặng File mẫu tính cao độ truyền nhiều trạm máy và nhiều mốc cao độ
    • Thích
    • Cảm ơn
Trả lời
9
Đọc
12K
QTCD2
Q
Hai Lúa Miền Tây
  • Question
Hàm groupby và pivot_table của Python trong Excel
    • Thích
    • Yêu thích
Trả lời
15
Đọc
594
Duy Tùng 9x
Duy Tùng 9x
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom