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

Chia sẻ bởi:hands

★★★★★

‹ Hàm tính tổng có tham chiếu theo... Lặp dữ liệu nhiều lần theo từng... ›

Quảng cáo

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.

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.

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!

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.

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

www.giaiphapexcel.com/diendan/threads/ch%E1%BB%89nh-s%E1%BB%ADa-code-trong-nh%E1%BA%ADt-k%C3%BD-thi-c%C3%B4ng-%C4%91%E1%BB%83-l%E1%BA%A5y-d%E1%BB%AF-li%E1%BB%87u-t%E1%BB%AB-c%E1%BB%99t-y%C3%AAu-c%E1%BA%A7u-nghi%E1%BB%87m-thu.163964/