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

[maithangbs]

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

 

[huuthang_bd]

Ồ, bác làm cách nào mà các đường nó liền mạch ô này sang ô kia được vậy ạ?

Làm như trong file.
Tôi không biết viết code nhưng nếu làm bằng tay được thì chắc viết code tự động được đúng không.

 

[cantl]

Làm như trong file.
Tôi không biết viết code nhưng nếu làm bằng tay được thì chắc viết code tự động được đúng không.

Thế này không tự động được bác ạ, vẫn phải code rồi.
Và có phải bác chặn 2 đầu của đoạn tiến độ không? Có điều em thấy có ô có ký tự, có ô lại không có gì, lạ ghê cơ.

Bảng tiến độ này sao không dùng MS Project nhỉ?

Excel nó dễ tùy biến và khi chỉ cần tiến độ đơn giản thôi bác ạ.

 

[thanhlanh]

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

Mình hay sử dụng cây nhà lá vườn, bạn tham khảo: https://www.mediafire.com/file/qfi2vtbqtnyxh9x/Tien_do_thi_cong_TC2022.xlsm/file

 

[huuthang_bd]

Thế này không tự động được bác ạ, vẫn phải code rồi.

Thì tôi nói viết code tự động theo kết quả mẫu trong file đó chứ có nói file đó tự động đâu.

 

[cantl]

Mình hay sử dụng cây nhà lá vườn, bạn tham khảo: https://www.mediafire.com/file/qfi2vtbqtnyxh9x/Tien_do_thi_cong_TC2022.xlsm/file

File này số ngày chu kỳ không phải 1 ngày mà là 15 ngày/ô, tiến độ công việc 10 ngày, vẫn bị tô hết cả ô hả bác?
Nếu chu kỳ tiến độ khác 1 (2, 5, 10, ... ngày)

thì chắc phải vẽ hoặc chuyển sang Project rồi.

Đây là phương án chế từ bác bebo, dùng gạch đá thay cho đường màu mè, nhưng dùng ..._Change Full Sheet là máy phải có Ram 1TB.

Option Explicit
Sub tiendo()
Dim lr&, j&, ce As Range, ngaybd As Double, ngaykt As Double
Dim ce1Left, ce1Top, ce2Left, ce2Top
Dim rgTiendo As Range
Application.ScreenUpdating = False ' tat man hinh nhap nhay
Range("N11:AU28").Value = ""
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
    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
            ce.Offset(, j - ce.Column - 1).Value = " "
            ce.Offset(, j - ce.Column).Value = Application.Rept(IIf(ce <> "", ChrW(9472), ChrW(9552)), 5000)
        Set rgTiendo = ce.Offset(, j - ce.Column)
        End If
        If Cells(9, j).Value = ngaykt Then
            ce.Offset(, j - ce.Column + 1).Value = " "
        On Error Resume Next
        Set rgTiendo = rgTiendo.Resize(1, ngaykt - ngaybd)
            Exit For
        End If
    Next
z:
Next
Application.ScreenUpdating = True ' bat cap nhat man hinh tro lai
End Sub

 

[huuthang_bd]

File này số ngày chu kỳ không phải 1 ngày mà là 15 ngày/ô, tiến độ công việc 10 ngày, vẫn bị tô hết cả ô hả bác?
Nếu chu kỳ tiến độ khác 1 (2, 5, 10, ... ngày)
View attachment 295691
thì chắc phải vẽ hoặc chuyển sang Project rồi.

Đây là phương án chế từ bác bebo, dùng gạch đá thay cho đường màu mè, nhưng dùng ..._Change Full Sheet là máy phải có Ram 1TB.

Option Explicit
Sub tiendo()
Dim lr&, j&, ce As Range, ngaybd As Double, ngaykt As Double
Dim ce1Left, ce1Top, ce2Left, ce2Top
Dim rgTiendo As Range
Application.ScreenUpdating = False ' tat man hinh nhap nhay
Range("N11:AU28").Value = ""
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
    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
            ce.Offset(, j - ce.Column - 1).Value = " "
            ce.Offset(, j - ce.Column).Value = Application.Rept(IIf(ce <> "", ChrW(9472), ChrW(9552)), 5000)
        Set rgTiendo = ce.Offset(, j - ce.Column)
        End If
        If Cells(9, j).Value = ngaykt Then
            ce.Offset(, j - ce.Column + 1).Value = " "
        On Error Resume Next
        Set rgTiendo = rgTiendo.Resize(1, ngaykt - ngaybd)
            Exit For
        End If
    Next
z:
Next
Application.ScreenUpdating = True ' bat cap nhat man hinh tro lai
End Sub

Đã dùng chuỗi thì ai lại duyệt từng ô như thế. Dùng mảng thì ram 2gb cũng chạy vèo vèo.

 

[cantl]

Đã dùng chuỗi thì ai lại duyệt từng ô như thế. Dùng mảng thì ram 2gb cũng chạy vèo vèo.

Em tận dụng code bác bebo và luyện thêm thôi bác. Chứ để viết lại từ đầu thì khó quá.

 

[huuthang_bd]

Em tận dụng code bác bebo và luyện thêm thôi bác. Chứ để viết lại từ đầu thì khó quá.

Vậy là bạn luyện sửa code chứ có phải luyện viết code đâu.

Sub tiendo()
    Dim lFirstDay As Long, lLastDay As Long, lDays As Long, lFr As Long, lTo As Long
    Dim Sh As Worksheet, aData As Variant, aResult As Variant, aLine As Variant, lLastRow As Long, i As Long
    Const lFirstRow As Long = 11
    aLine = Array(String(255, ChrW(9608)), String(100, ChrW(9644))) '9608 - 9644 / 9552 - 9472
    Set Sh = Sheet13
    lFirstDay = Sh.Range("N9").Value2
    lLastDay = Sh.Range("AU9").Value2
    lDays = lLastDay - lFirstDay + 1
    lLastRow = Sh.Range("I1000000").End(xlUp).Row
    aData = Sh.Range("I" & lFirstRow & ":K" & lLastRow).Value2
    ReDim aResult(1 To UBound(aData, 1), 0 To lDays + 1)
    For i = 1 To UBound(aData, 1)
        If aData(i, 1) <= lLastDay And aData(i, 3) >= lFirstDay Then
            lFr = Application.Max(aData(i, 1) - lFirstDay + 1, 1)
            lTo = Application.Min(aData(i, 3) - lFirstDay + 1, lDays)
            aResult(i, lFr - 1) = "'"
            aResult(i, lTo + 1) = "'"
            aResult(i, lFr) = aLine(Sgn(Len(aData(i, 2))))
        End If
    Next
    With Sh.Range("M" & lFirstRow).Resize(UBound(aResult, 1), lDays + 1)
        .HorizontalAlignment = xlCenterAcrossSelection
        .Value = aResult
    End With
End Sub

 

[Nhattanktnn]

Vậy là bạn luyện sửa code chứ có phải luyện viết code đâu.

Sub tiendo()
    Dim lFirstDay As Long, lLastDay As Long, lDays As Long, lFr As Long, lTo As Long
    Dim Sh As Worksheet, aData As Variant, aResult As Variant, aLine As Variant, lLastRow As Long, i As Long
    Const lFirstRow As Long = 11
    aLine = Array(String(255, ChrW(9608)), String(100, ChrW(9644))) '9608 - 9644 / 9552 - 9472
    Set Sh = Sheet13
    lFirstDay = Sh.Range("N9").Value2
    lLastDay = Sh.Range("AU9").Value2
    lDays = lLastDay - lFirstDay + 1
    lLastRow = Sh.Range("I1000000").End(xlUp).Row
    aData = Sh.Range("I" & lFirstRow & ":K" & lLastRow).Value2
    ReDim aResult(1 To UBound(aData, 1), 0 To lDays + 1)
    For i = 1 To UBound(aData, 1)
        If aData(i, 1) <= lLastDay And aData(i, 3) >= lFirstDay Then
            lFr = Application.Max(aData(i, 1) - lFirstDay + 1, 1)
            lTo = Application.Min(aData(i, 3) - lFirstDay + 1, lDays)
            aResult(i, 0) = "'"
            aResult(i, lFr - 1) = "'"
            aResult(i, lTo + 1) = "'"
            aResult(i, lDays) = "'"
            aResult(i, lFr) = aLine(Sgn(Len(aData(i, 2))))
        End If
    Next
    With Sh.Range("M" & lFirstRow).Resize(UBound(aResult, 1), lDays + 1)
        .HorizontalAlignment = xlCenterAcrossSelection
        .Value = aResult
    End With
End Sub

Cuối cùng đã dụ được rắn ra khỏi hang

 

[huuthang_bd]

Cuối cùng đã dụ được rắn ra khỏi hang

Đã gợi ý vậy rồi mà làm như bài #25 thấy nó... ngứa.

 

[Nhattanktnn]

Đã gợi ý vậy rồi mà làm như bài #25 thấy nó... ngứa.

Biết đâu họ cố tình gây "ngứa" anh

 

[cantl]

Biết đâu họ cố tình gây "ngứa" anh

Hehe, vô thì có chứ cố thì chia rẽ tình thương mến thương mất rồi.

 

[Maika8008]

Làm như trong file.
Tôi không biết viết code nhưng nếu làm bằng tay được thì chắc viết code tự động được đúng không.

Biết đâu họ cố tình gây "ngứa" anh

Chính xác là cố tình gây ngứa vì cái chỗ đậm đậm đó