alibaba2209
Thành viên thường trực




- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
Sub Nhatky()
Dim sArr(), dArr(1 To 65535, 1 To 5)
Dim i As Long, j As Long, k As Long
Dim Bd, Kt, Nt
With Sheets("List BB")
sArr = .Range(.[C2], .[C65536].End(xlUp)).Resize(, 8).Value2
End With
For i = 1 To UBound(sArr, 1)
Bd = sArr(i, 4): Kt = sArr(i, 6): Nt = sArr(i, 8)
If sArr(i, 1) <> Empty Then
For j = 1 To Kt - Bd + 1
k = k + 1
dArr(k, 1) = k
dArr(k, 2) = Bd + j - 1
dArr(k, 3) = sArr(i, 1)
dArr(k, 4) = sArr(i, 2)
dArr(k, 5) = sArr(i, 3)
Next j
End If
If sArr(i, 1) <> Empty And sArr(i, 8) <> Empty Then
k = k + 1
dArr(k, 1) = k
dArr(k, 2) = Nt
dArr(k, 3) = "Nghi" & ChrW$(7879) & "m thu " & sArr(i, 1)
dArr(k, 4) = sArr(i, 2)
dArr(k, 5) = sArr(i, 3)
End If
Next i
Sheets("Xuat Tong Nhat Ky").Range("A2:G65535").ClearContents
Sheets("Xuat Tong Nhat Ky").Resize(k, 5) = dArr()
End Sub
code bị lỗi. Bạn xem dùm lại chútBạn đọc bài này thử xem: http://www.giaiphapexcel.com/forum/...-lại-công-việc-theo-ngày-(Nhật-ký-công-trình)
Không bạn dùng thử Code này xem sao
Mã:Sub Nhatky() Dim sArr(), dArr(1 To 65535, 1 To 5) Dim i As Long, j As Long, k As Long Dim Bd, Kt, Nt With Sheets("List BB") sArr = .Range(.[C2], .[C65536].End(xlUp)).Resize(, 8).Value2 End With For i = 1 To UBound(sArr, 1) Bd = sArr(i, 4): Kt = sArr(i, 6): Nt = sArr(i, 8) If sArr(i, 1) <> Empty Then For j = 1 To Kt - Bd + 1 k = k + 1 dArr(k, 1) = k dArr(k, 2) = Bd + j - 1 dArr(k, 3) = sArr(i, 1) dArr(k, 4) = sArr(i, 2) dArr(k, 5) = sArr(i, 3) Next j End If If sArr(i, 1) <> Empty And sArr(i, 8) <> Empty Then k = k + 1 dArr(k, 1) = k dArr(k, 2) = Nt dArr(k, 3) = "Nghi" & ChrW$(7879) & "m thu " & sArr(i, 1) dArr(k, 4) = sArr(i, 2) dArr(k, 5) = sArr(i, 3) End If Next i Sheets("Xuat Tong Nhat Ky").Range("A2:G65535").ClearContents Sheets("Xuat Tong Nhat Ky").Resize(k, 5) = dArr() End Sub
Xin lỗi mình nhầm. Bạn thay dòng này Sheets("Xuat Tong Nhat Ky")Resize(k, 5) = dArr lại như thế này Sheets("Xuat Tong Nhat Ky").Range("A2").Resize(k, 5) = dArr
Ngày có thể theo thứ tự được không bạn như này này[TABLE="width: 554"]
[TR]
[TD]01/01/2016[/TD]
[TD]Đá hộc xây vữa M100 móng, chân khay, sân cống[/TD]
[/TR]
[TR]
[TD]02/01/2016[/TD]
[TD]Đá hộc xây vữa M100 móng, chân khay, sân cống[/TD]
[/TR]
[TR]
[TD]03/01/2016[/TD]
[TD]Đá hộc xây vữa M100 móng, chân khay, sân cống[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Nghiệm thu Đá hộc xây vữa M100 móng, chân khay, sân cống[/TD]
[/TR]
[TR]
[TD]02/01/2016[/TD]
[TD]Bê tông chèn ống cống M100[/TD]
[/TR]
[TR]
[TD]03/01/2016[/TD]
[TD]Bê tông chèn ống cống M100[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Nghiệm thu Bê tông chèn ống cống M100[/TD]
[/TR]
[TR]
[TD]03/01/2016[/TD]
[TD]Lắp đặt ống cống D100[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Lắp đặt ống cống D100[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Nghiệm thu Lắp đặt ống cống D100[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Bê tông chèn ống cống M100[/TD]
[/TR]
[/TABLE]
[TABLE="width: 554"]
[TR]
[TD]01/01/2016[/TD]
[TD]Đá hộc xây vữa M100 móng, chân khay, sân cống[/TD]
[/TR]
[TR]
[TD]02/01/2016[/TD]
[TD]Đá hộc xây vữa M100 móng, chân khay, sân cống[/TD]
[/TR]
[TR]
[TD]02/01/2016[/TD]
[TD]Bê tông chèn ống cống M100[/TD]
[/TR]
[TR]
[TD]03/01/2016[/TD]
[TD]Đá hộc xây vữa M100 móng, chân khay, sân cống[/TD]
[/TR]
[TR]
[TD]03/01/2016[/TD]
[TD]Bê tông chèn ống cống M100[/TD]
[/TR]
[TR]
[TD]03/01/2016[/TD]
[TD]Lắp đặt ống cống D100[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Nghiệm thu Đá hộc xây vữa M100 móng, chân khay, sân cống[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Nghiệm thu Bê tông chèn ống cống M100[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Lắp đặt ống cống D100[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Nghiệm thu Lắp đặt ống cống D100[/TD]
[/TR]
[TR]
[TD]04/01/2016[/TD]
[TD]Bê tông chèn ống cống M100[/TD]
[/TR]
[/TABLE]
như trong file! sheet "List BB" ô C2 có thời gian làm từ ngày mùng 1, 2, 3, e muốn nó xuất ra 3 ngày liên tục theo fom sheet "Xuat Tong Nhat Ky"
Vâng cột F để em ^^! Macro1 bỏ đi à anh. Muốn đổi mầu thì trong khu này à anh [If Left(.Range("C" & i), 4) = "Nthu" Then .Range("C" & i).Resize(, 3).Font.ColorIndex = 3] bảng số mầu xem ở đâu ạBạn xem file này, tôi cố gắng tạo kết quả giống như ý bạn nhưng còn cột F công thức "siêu" quá không hiểu nên bạn tự lập công thức cho cột F nhé.
Dạ vâng! em cảm ơn.. file demo thôi anh ạHình như quy trình nghiệm thu bê tông của bạn sai rồi thì phải:
Đổ bê tông ngày 4/1 đến 6/1/2017; Nghiệm thu 7/1/2016
Mà Theo TCVN 4453-1995 thì:
- Khi cường độ bê tông đạt 70% cường độ thiết kế thì được triển khai các công việc tiếp theo
- Khi cường độ bê tông đạt 100% cường độ thiết kế thì nghiệm thu bê tông
Thầy ơi. Bây giờ mình muốn gạch chân chữ N.thu (N.thu: ) thì phải làm sao ạBạn xem file này, tôi cố gắng tạo kết quả giống như ý bạn nhưng còn cột F công thức "siêu" quá không hiểu nên bạn tự lập công thức cho cột F nhé.
Bạn dùng tạm Code này nha:anh ơi! hộ em sửa chút code. khóa vùng in có giữ liệu. định dạng kẻ ô như này ạ
Sub Dinhdang()
Dim Edate As Long, Er As Long, i As Long
Application.ScreenUpdating = False
Er = Sheet1.Range("C65535").End(3).Row
Sheet1.Range("A3:G" & Er).Borders.LineStyle = xlNone
For i = Er To 3 Step -1
If Sheet1.Range("B" & i) <> Empty Then
Edate = Sheet1.Range("B" & i).End(xlDown).Row
If i = Er Then
Sheet1.Range("A" & i & ":G" & i).Borders.LineStyle = xlContinuous
Sheet1.Range("A" & i & ":G" & i).Borders(xlInsideHorizontal).Weight = xlHairline
Else
Sheet1.Range("A" & Edate - 1 & ":G" & i).Borders.LineStyle = xlContinuous
Sheet1.Range("A" & Edate - 1 & ":G" & i).Borders(xlInsideHorizontal).Weight = xlHairline
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
Vâng em cảm ơn nhiều ạ!Bạn dùng tạm Code này nha:
Mã:Sub Dinhdang() Dim Edate As Long, Er As Long, i As Long Application.ScreenUpdating = False Er = Sheet1.Range("C65535").End(3).Row Sheet1.Range("A3:G" & Er).Borders.LineStyle = xlNone For i = Er To 3 Step -1 If Sheet1.Range("B" & i) <> Empty Then Edate = Sheet1.Range("B" & i).End(xlDown).Row If i = Er Then Sheet1.Range("A" & i & ":G" & i).Borders.LineStyle = xlContinuous Sheet1.Range("A" & i & ":G" & i).Borders(xlInsideHorizontal).Weight = xlHairline Else Sheet1.Range("A" & Edate - 1 & ":G" & i).Borders.LineStyle = xlContinuous Sheet1.Range("A" & Edate - 1 & ":G" & i).Borders(xlInsideHorizontal).Weight = xlHairline End If End If Next i Application.ScreenUpdating = True End Sub
Anh ơi còn khóa Vùng in nữa ạ..phiền anh tý nữa!Bạn dùng tạm Code này nha:
Mã:Sub Dinhdang() Dim Edate As Long, Er As Long, i As Long Application.ScreenUpdating = False Er = Sheet1.Range("C65535").End(3).Row Sheet1.Range("A3:G" & Er).Borders.LineStyle = xlNone For i = Er To 3 Step -1 If Sheet1.Range("B" & i) <> Empty Then Edate = Sheet1.Range("B" & i).End(xlDown).Row If i = Er Then Sheet1.Range("A" & i & ":G" & i).Borders.LineStyle = xlContinuous Sheet1.Range("A" & i & ":G" & i).Borders(xlInsideHorizontal).Weight = xlHairline Else Sheet1.Range("A" & Edate - 1 & ":G" & i).Borders.LineStyle = xlContinuous Sheet1.Range("A" & Edate - 1 & ":G" & i).Borders(xlInsideHorizontal).Weight = xlHairline End If End If Next i Application.ScreenUpdating = True End Sub
Thầy ơi. Bây giờ mình muốn gạch chân chữ N.thu (N.thu: ) thì phải làm sao ạ
If Left(.Range("C" & i), 4) = "Nthu" Then
.Range("C" & i).Resize(, 3).Font.ColorIndex = 3
.Range("C" & i).Characters(Start:=1, Length:=5).Font.Underline = xlUnderlineStyleSingle '<--------------'
End If
Em cám ơn thầy. Vấn đề này em tìm mãi mà không làm được. Hôm nay mới được thầy chỉ cho.Bạn thử Record Macro xem sao.
Ví dụ trong Code của tôi thêm 1 dòng này
PHP:If Left(.Range("C" & i), 4) = "Nthu" Then .Range("C" & i).Resize(, 3).Font.ColorIndex = 3 .Range("C" & i).Characters(Start:=1, Length:=5).Font.Underline = xlUnderlineStyleSingle '<--------------' End If
Cái này mình Record Macro bạn xem thử nha:Anh ơi còn khóa Vùng in nữa ạ..phiền anh tý nữa!
[FONT=Verdana]Sheet1.PageSetup.PrintArea = "$A$1:$F$" & [/FONT][COLOR=#0000ff][FONT=Verdana]Sheet1.Range("C65535").End(3).Row[/FONT][/COLOR]
cảm ơn bác nhiều! những bác kê em có 1 file làm về hồ sơ riêng rồi, đây là 1 ví dụ nhỏ e up lên cho nhẹ file. Bác cũng là dân XD chính cống nhỉ!Cái này mình Record Macro bạn xem thử nha:
Mã:[FONT=Verdana]Sheet1.PageSetup.PrintArea = "$A$1:$F$" & [/FONT][COLOR=#0000ff][FONT=Verdana]Sheet1.Range("C65535").End(3).Row[/FONT][/COLOR]
Cái Sub Dinhdang chỉ đúng với dữ liệu của bạn hiện tại
Nếu phát triển nhật ký thi công như file bạn đang làm ( từ ngày bắt đầu đến ngày kết thúc) còn thiếu nhiều.
Ví dụ:
1. Công tác đất:
1.1 Kiểm tra thành phần hạt, độ ẩm theo tần xuất
1.2. Kiểm tra chỉ tiêu cơ lý theo tần xuất
2. Công tác bê tông
2.1 Lấy mẫu thí nghiệm
2.2 Thể hiện thời gian bảo dưỡng
...............
Vậy thì nhật ký thi công phải thể hiện hư thế nào...![]()
thầy ơi đoạn code này báo lỗi, bị ở chỗ nào thầy xem lại dùm em với ạBạn thử Record Macro xem sao.
Ví dụ trong Code của tôi thêm 1 dòng này
PHP:If Left(.Range("C" & i), 4) = "Nthu" Then .Range("C" & i).Resize(, 3).Font.ColorIndex = 3 .Range("C" & i).Characters(Start:=1, Length:=5).Font.Underline = xlUnderlineStyleSingle '<--------------' End If
Option Explicit
Public Sub XuatNhatKy_TH()
Dim sArr(), dArr(1 To 1000, 1 To 5), i As Long, j As Long, k As Long, R As Long
getSpeed (True)
With Sheets("List BB")
sArr = .Range("C3", .Range("C3").End(xlDown)).Resize(, 8).Value
R = UBound(sArr)
End With
For i = 1 To R
For j = sArr(i, 4) To sArr(i, 6)
k = k + 1: dArr(k, 1) = k
dArr(k, 2) = j: dArr(k, 3) = sArr(i, 1)
dArr(k, 4) = sArr(i, 2): dArr(k, 5) = sArr(i, 3)
Next j
k = k + 1: dArr(k, 1) = k
dArr(k, 2) = sArr(i, 8): dArr(k, 3) = "Nthu: " & sArr(i, 1)
dArr(k, 4) = sArr(i, 2): dArr(k, 5) = sArr(i, 3)
Next i
With Sheets("Xuat Tong Nhat Ky")
.Range("A2").Resize(1000, 5).ClearContents
.Range("C2").Resize(1000, 3).Font.ColorIndex = 0
If k Then
.Range("A2").Resize(k, 5) = dArr
.Range("B2").Resize(k, 4).Sort Key1:=.Range("B2")
For i = k + 1 To 3 Step -1
If .Range("B" & i) = .Range("B" & i - 1) Then .Range("B" & i).ClearContents
If Left(.Range("C" & i), 4) = "Nthu" Then .Range("C" & i).Resize(, 3).Font.ColorIndex = 3
Next i
ThoiTiet
DinhDang
End If
End With
getSpeed (False)
End Sub
Public Sub ThoiTiet()
Dim sArr(), dArr(), i As Long, j As Long
sArr = Sheets("Thoi Tiet").Range("C2:AG77").Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(sArr) Step 2
For j = 1 To UBound(sArr, 2)
If sArr(i + 1, j) <> Empty Then .Add sArr(i, j), sArr(i + 1, j)
Next j
Next i
sArr = Range("B2", Range("B65536").End(xlUp)).Value
ReDim dArr(1 To UBound(sArr), 1 To 1)
For i = 1 To UBound(sArr)
If sArr(i, 1) <> Empty Then
If .Exists(sArr(i, 1)) Then dArr(i, 1) = .Item(sArr(i, 1))
End If
Next i
End With
Range("G2").Resize(i - 1) = dArr
End Sub
Sub DinhDang()
Dim Edate As Long, Er As Long, i As Long
Er = Sheets("Xuat Tong Nhat Ky").Range("C65535").End(3).Row
For i = Er To 2 Step -1
If Sheets("Xuat Tong Nhat Ky").Range("B" & i) <> Empty Then
Edate = Sheets("Xuat Tong Nhat Ky").Range("B" & i).End(xlDown).Row
If i = Er Then
Sheets("Xuat Tong Nhat Ky").Range("A" & i & ":G" & i).Borders.LineStyle = xlContinuous
Sheets("Xuat Tong Nhat Ky").Range("A" & i & ":G" & i).Borders(xlInsideHorizontal).Weight = xlHairline
Else
Sheets("Xuat Tong Nhat Ky").Range("A" & Edate - 1 & ":G" & i).Borders.LineStyle = xlContinuous
Sheets("Xuat Tong Nhat Ky").Range("A" & Edate - 1 & ":G" & i).Borders(xlInsideHorizontal).Weight = xlHairline
Sheets("Xuat Tong Nhat Ky").PageSetup.PrintArea = "$A$1:$G$" & Sheets("Xuat Tong Nhat Ky").Range("C65535").End(3).Row '<<<<< Code khóa vùng In
End If
End If
Next i
End Sub