Chỉnh sửa code trong Nhật ký thi công để lấy dữ liệu từ cột Yêu cầu Nghiệm thu (2 người xem)

[vanle33]

Tôi muốn chỉnh sửa code trong file đính kèm để lấy dữ liệu từ cột Yêu cầu để xuất được kết quả sang Sheet "04-Nhat ky".
Kết quả ở cột D sau khi kích vào nút LE VAN có dạng: Yêu cầu NT & Nội dung công việc ở cột C Sheet "01-Danh muc".
Tương tự như Nghiêm thu công viêc ....
Code trong nút LE VAN là:

Public Sub hello2HamDuyet()

Dim r As Long, k As Long, dArr(1 To 65000, 1 To 4), arr

Dim startDate As Date, endDate As Date, ub As Long, h As Boolean

arr = Sheet1.Range("A19:K" & Sheet1.[A65000].End(xlUp).Row).Value

ub = UBound(arr)

startDate = Sheet5.[F5].Value

endDate = Sheet5.[F6].Value

With Sheet4

    .Range("A16:D" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row).ClearContents

    k = 1

    Do While WorksheetFunction.RoundDown(startDate, 0) <= _

             WorksheetFunction.RoundDown(endDate, 0)

        r = 1: h = False

        dArr(k, 1) = k

        dArr(k, 2) = startDate

        dArr(k, 4) = " " 'Da xoa chu : Mua cong truong nghi

        Do While arr(r, 1) <> arr(ub, 1)

            If arr(r, 11) = startDate Then

                dArr(k, 1) = k

                dArr(k, 2) = startDate

                dArr(k, 3) = arr(r, 2)

                dArr(k, 4) = "Nghiêm thu công viêc " & arr(r, 3) ' Them chu : cong viec

                k = k + 1: h = True

            End If

            If arr(r, 6) <= startDate And arr(r, 7) >= startDate Then

                dArr(k, 1) = k





                dArr(k, 2) = startDate





                dArr(k, 3) = arr(r, 2)

                dArr(k, 4) = "" & arr(r, 3) 'Bo chu : Thi cong

                k = k + 1: h = True

            End If

            r = r + 1

        Loop

        startDate = startDate + 1

        If Not h Then k = k + 1

    Loop

  

Dim l, Tren, Duoi As Long

l = 1

For i = 1 To k - 1

Tren = dArr(i, 2)

Duoi = dArr(i + 1, 2)

If Tren <> "" Then Tam = Tren

If Tam = Duoi Then

dArr(i + 1, 2) = ""

End If

If dArr(i, 2) <> "" Then

dArr(i, 1) = l

l = l + 1

Else

dArr(i, 1) = ""

End If

Next i





    .Range("A16:D16").Resize(k).Value = dArr

End With

End Sub

Tôi đang sử dụng Excel 2010 32 bit.
Xin nhờ các thành viên trợ giúp.
Xin cảm ơn.

 

[Thóc Sama]

1. Tốt nhất là bác mở khoá code để có ai chỉnh sửa code còn có cái mà test đúng sai.
2. Để nhanh chóng được hỗ trợ thì nên điền kết quả mong muốn một vài trường hợp.
3. Thông thường "nếu là tôi" thì "nếu có thể" tôi thích viết code mới thay vì đọc và dịch code người khác.
--> Một số bài của bác tôi thấy để giải quyết xong vấn đề thường phải xác nhận qua - lại rất nhiều lần.
Có lẽ bác đang vướng phải một số vấn đề trên chăng?

 

[vanle33]

1. Tốt nhất là bác mở khoá code để có ai chỉnh sửa code còn có cái mà test đúng sai.
2. Để nhanh chóng được hỗ trợ thì nên điền kết quả mong muốn một vài trường hợp.
3. Thông thường "nếu là tôi" thì "nếu có thể" tôi thích viết code mới thay vì đọc và dịch code người khác.
--> Một số bài của bác tôi thấy để giải quyết xong vấn đề thường phải xác nhận qua - lại rất nhiều lần.
Có lẽ bác đang vướng phải một số vấn đề trên chăng?

Code trên của các thành viên khác. Tôi chỉ biết cách 'Đánh tráo' mà không biết gỡ pass code kiểu gì. hihi
Nên tôi mới đính kèm toàn bộ code nên bài #1.
Kết quả xuất ra như tôi nói ở #1.

 

[Thóc Sama]

Code trên của các thành viên khác. Tôi chỉ biết cách 'Đánh tráo' mà không biết gỡ pass code kiểu gì. hihi
Nên tôi mới đính kèm toàn bộ code nên bài #1.
Kết quả xuất ra như tôi nói ở #1.

Xời, lại vấn đề tác quyền chăng?
Thế này thì chịu rồi, bác chờ các thành viên khác giúp ha!

 

[bebo021999]

1) Bạn gỡ password VBA, sau đó lưu file lại dạng .xlsm
2) Với kết quả sau khi nhấn nút "LE VAN", bạn cần sửa chữa, bổ sung thêm bớt gì?
Nhập tay kết quả vào cột khác (cột F) sheet Nhat ký, để đối chiếu

 

[vanle33]

1) Bạn gỡ password VBA, sau đó lưu file lại dạng .xlsm
2) Với kết quả sau khi nhấn nút "LE VAN", bạn cần sửa chữa, bổ sung thêm bớt gì?
Nhập tay kết quả vào cột khác (cột F) sheet Nhat ký, để đối chiếu

1) Làm như bác hướng dẫn nhưng mở lại file thì vẫn hỏi pass. Em không biết pass thật!
2) Những chỗ bôi vàng ở "Nhat ky" là em mới thêm = thủ công vào a.

 

[bebo021999]

Thử code này nhé : ...

Option Explicit
Sub Nghiemthu()
Dim lr&, i, j&, k&, stt&, min, max, rng, r As Range, arr(1 To 10000, 1 To 4)
Dim bd, kt, yc, nt
Dim dic As Object, key, s
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("01-Danh muc")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    Set r = Union(.Range("F20:G" & lr), .Range("J20:K" & lr))
    With WorksheetFunction
        min = .min(r): max = .max(r)
    End With
    rng = .Range("A20:L" & lr).Value2
    For j = min To max
        For i = 1 To UBound(rng)
            bd = rng(i, 6): kt = rng(i, 7): yc = rng(i, 10): nt = rng(i, 11)
            If j >= bd And j <= kt Then If Not dic.exists(j & "|" & rng(i, 1) & "|TC") Then dic.Add j & "|" & rng(i, 1) & "|TC", j
            If j >= yc And j <= nt Then If Not dic.exists(j & "|" & rng(i, 1) & "|YC") Then dic.Add j & "|" & rng(i, 1) & "|YC", j
            If j = nt Then If Not dic.exists(j & "|" & rng(i, 1) & "|NT") Then dic.Add j & "|" & rng(i, 1) & "|NT", j
        Next
    Next
    For Each key In dic.keys
        k = k + 1
        arr(k, 2) = dic(key): s = Split(key, "|")
        For i = 1 To UBound(rng)
            If CDbl(s(1)) = rng(i, 1) Then
                arr(k, 3) = rng(i, 2): arr(k, 4) = IIf(s(2) = "TC", "", IIf(s(2) = "YC", "Yeu cau Nghiem thu: ", "Nghiem thu: ")) & rng(i, 3)
            End If
        Next
    Next
End With
With Sheets("04-Nhat ky")
    .Range("A16:E10000").ClearContents
    .Range("A16").Resize(k, 4) = arr
    lr = .Cells(Rows.Count, "C").End(xlUp).Row
    rng = .Range("B15:B" & lr).Value
    For i = 2 To UBound(rng)
        If rng(i, 1) <> rng(i - 1, 1) Then
            stt = stt + 1
            .Cells(i + 14, 1) = stt
        Else
            .Cells(i + 14, 2).ClearContents
        End If
    Next
End With
End Sub

 

[vanle33]

@bebo021999 :
+) Cám ơn bác.
+) Nhưng code trên khác so với code ở bài #1 em đã up.
+) Khi em thay đổi dữ liệu ở các cell tô vàng ở ảnh dưới thì kết quả sau khi em nhấn LE VAN bên Sheet Nhat ky bị sai. Ví dụ: ngày 26/9, ngày 27/9, ngày 28/9 không có YC ở sheet Danh muc mà ở sheet Nhat ky vẫn có 'Yeu cau Nghiem thu: §µo kªnh m¬ng b»ng m¸y kÕt hîp thñ c«ng, ®æ lªn ph¬ng tiÖn vËn chuyÓn, ®Êt cÊp I' ở 3 ngày này.

+) Ý em chỉ là: Lấy các dữ liệu đang có ở cột B, C, F, G, J, K sheet Danh muc rồi tổng hợp theo ngày đưa sang các cột B, C, D sheet Nhat ky theo từng ngày. Công việc thì kéo dài trong khoảng thời gian, Yêu cầu thì thêm chữ Yeu cau Nghiem thu trước tên công việc, Nghiệm thu thì thêm chữ Nghiem thu trước tên công việc.

 

[bebo021999]

Thêm 1 điều kiện yc<>0 vô:

If  j >= yc And j <= nt Then If Not dic.exists(j & "|" & rng(i, 1) & "|YC") Then dic.Add j & "|" & rng(i, 1) & "|YC", j

trở thành

If yc <> 0 And j >= yc And j <= nt Then If Not dic.exists(j & "|" & rng(i, 1) & "|YC") Then dic.Add j & "|" & rng(i, 1) & "|YC", j

 

[vanle33]

@bebo021999
Với dữ liệu ở ảnh dưới thì em chỉ muốn kết quả là Yeu cau Nghiem thu trong 1 ngày 21/11 chứ không phải Yeu cau từ ngày 21/11 đến 27/11.

Cảm ơn bác.

 

[bebo021999]

Có vẻ bạn chưa hiểu rõ cách vân hành của code nên gặp khó khăn khi chỉnh code.
Thay dòng này:

If yc <> 0 And j >= yc And j <= nt Then If Not dic.exists(j & "|" & rng(i, 1) & "|YC") Then dic.Add j & "|" & rng(i, 1) & "|YC", j

bằng

If j = yc  Then If Not dic.exists(j & "|" & rng(i, 1) & "|YC") Then dic.Add j & "|" & rng(i, 1) & "|YC", j

 

[vanle33]

ok bác. Code chuẩn với dữ liệu hiện tại rồi a.
Em là mù tịt, không đọc được code. Chỉ biết thay thế 1 số dòng code.

 

[vanle33]

Với dữ liệu như file dưới. Có 1 số dòng chưa có dữ liệu, ví dụ như Stt từ 46 đến 53, ở các cột F, G, J, K em sẽ thêm vào sau khi thi công hạng mục đó ở hiện trường.
Khi kích để chạy code ở sheet Nhat ky thì báo lỗi nền vàng ở dòng If CDbl(s(1)) = rng(i, 1) Then. Mong bác @bebo021999 chỉnh sửa code để chạy được code một cách bình thường với tất cả dữ liệu hiện có ạ.

 

[vanle33]

Sáng hôm nay tôi bỗng dưng nhớ ra thử tìm lỗi bằng cách Ctrl+H / Find what nhập 1900 rồi kích Find Next. Thì tìm ra được thủ phạm ở F384 là 00/01/1900, xóa đi là kích chạy code 1 cách ngon lành ở Sheet Nhat ky.