alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
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"
Nhờ các a viết cho đoạn code cho file (1 người xem)
- Thread starter alibaba2209
- Ngày gửi
Người dùng đang xem chủ đề này
PacificPR
Thành viên mới
- Tham gia
- 6/5/16
- Bài viết
- 1,997
- Được thích
- 2,750
Bạ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
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
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
code bị lỗi. Bạn xem dùm lại chút
Upvote
0
PacificPR
Thành viên mới
- Tham gia
- 6/5/16
- Bài viết
- 1,997
- Được thích
- 2,750
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
Đổ 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
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
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 ạ
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
Dạ vâng! em cảm ơn.. file demo thôi anh ạ
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
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 ạ
Upvote
0
PacificPR
Thành viên mới
- Tham gia
- 6/5/16
- Bài viết
- 1,997
- Được thích
- 2,750
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
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
Vâng em cảm ơn nhiều ạ!
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
Anh ơi còn khóa Vùng in nữa ạ..phiền anh tý nữa!
Upvote
0
Ba Tê
Cạo Rồi Khỏi Gội
- Tham gia
- 5/5/09
- Bài viết
- 12,123
- Được thích
- 17,590
- Giới tính
- Nam
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
Upvote
0
PacificPR
Thành viên mới
- Tham gia
- 6/5/16
- Bài viết
- 1,997
- Được thích
- 2,750
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...
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
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...
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
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 ạ
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
e xóa 2 cột đi giờ phải đổi code như nào a nhỉ
Upvote
0
PacificPR
Thành viên mới
- Tham gia
- 6/5/16
- Bài viết
- 1,997
- Được thích
- 2,750
Bạn xem sửa lại như thế này có được không:
Mã:
Public Sub GPE_EPG()
Application.ScreenUpdating = False
Dim sArr(), dArr(1 To 1000, 1 To 5), i As Long, j As Long, k As Long, R As Long, Edate As Long
With Sheets("List BB")
sArr = .Range("B3", .Range("B3").End(xlDown)).Resize(, 7).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, 7): dArr(k, 3) = "Nthu: " & sArr(i, 1)
dArr(k, 4) = sArr(i, 2): dArr(k, 5) = sArr(i, 3)
Next i
With Sheets("GPE")
.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
.Range("C" & i).Characters(Start:=1, Length:=5).Font.Underline = xlUnderlineStyleSingle
End If
Next i
.Range("A2:G65535").Borders.LineStyle = xlNone
.Range("A2 :G" & k+1).Borders.LineStyle = xlContinuous
.Range("A2 :G" & k+1).Borders(xlInsideHorizontal).Weight = xlHairline
For i = k + 1 To 3 Step -1
If .Range("B" & i) <> Empty Then
With .Range("A" & i & ":G" & i).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If
Next i
.PageSetup.PrintArea = "$A$1:$G$" & k + 1
Thoitiet
End If
End With
End Sub
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote
0
PacificPR
Thành viên mới
- Tham gia
- 6/5/16
- Bài viết
- 1,997
- Được thích
- 2,750
File có 3 Sheet thì chắc không cần dùng tới 3 cái nút đó đâu thầy nhỉ ... mà em cũng dốt thật thầy ạ ( Sử dụng 2 vòng lặp). Chỉ cần lồng 1 vòng lặp của thầy là được rồi. Hì hì
Mã:
Public Sub GPE_EPG()
Application.ScreenUpdating = False
Dim sArr(), dArr(1 To 1000, 1 To 7), i As Long, j As Long, k As Long, R As Long
With Sheets("List BB")
sArr = .Range("B3", .Range("B3").End(xlDown)).Resize(, 7).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, 7): dArr(k, 3) = "Nthu: " & sArr(i, 1)
dArr(k, 4) = sArr(i, 2): dArr(k, 5) = sArr(i, 3)
Next i
With Sheets("GPE")
.Range("A2").Resize(1000, 5).ClearContents
.Range("C2").Resize(1000, 3).Font.ColorIndex = 0
.Range("A2:G65535").Borders.LineStyle = xlNone
.Range("A2:G65535").Font.Underline = xlUnderlineStyleNone
If k Then
.Range("A2").Resize(k, 5) = dArr
.Range("B2").Resize(k, 4).Sort Key1:=.Range("B2")
.Range("A2").Resize(k, 7).Borders.LineStyle = xlContinuous
.Range("A2").Resize(k, 7).Borders(xlInsideHorizontal).Weight = xlHairline
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
.Range("C" & i).Characters(Start:=1, Length:=5).Font.Underline = xlUnderlineStyleSingle
End If
If .Range("B" & i) <> Empty Then
With .Range("A" & i & ":G" & i).Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End If
Next i
Thoitiet
.PageSetup.PrintArea = "$A$1:$G$" & k + 1
End If
End With
Application.ScreenUpdating = True
End Sub
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote
0
Ba Tê
Cạo Rồi Khỏi Gội
- Tham gia
- 5/5/09
- Bài viết
- 12,123
- Được thích
- 17,590
- Giới tính
- Nam
Tôi thì không quan tâm đến chuyện 1,2,3 vòng lặp, Code đẹp hay xấu. Cái "đã" của tôi là "giải toán đố", thấy bài nào "nhức đầu" một chút là "mò mẫm, sờ sẫm, rờ rẫm" chừng nào "ra" thì thôi.
mà em cũng dốt thật thầy ạ ( Sử dụng 2 vòng lặp). Chỉ cần lồng 1 vòng lặp của thầy là được rồi. Hì hì
....................
Vì cái nghề tôi bị "mặc cảm" người đời nói: mấy thằng "vai u thịt bắp đầu óc đơn thuần" (Tôi là giáo viên TDTT, thời bao cấp được trợ cấp nhu yếu phẩm hàng tháng nhiều hơn người khác nên họ nhìn mình hơi bị khác)
Động não cho vui thôi, nhưng động não 1 lần mà bị hỏi "dằn lân" là nghỉ, kiếm chuyện khác "mò mẫm....." cho "đã"
Lần chỉnh sửa cuối:
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
Em chân thành cảm ơn các thầy, các a đã giúp đỡ.. để thử code ạ!
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
code phê quá anh ơi! Giúp e thêm chút nữa ạ 1. nếu chữ dài quá sẽ tự mở rộng dòng -- 2. còn công thức này có thể coppy dc không anh nhỉ =IF(LEFT($C2,5)="Nthu:","",IF(SUMPRODUCT((ISNUMBER(FIND({"#","vữa"},$C2)))*1),"LM: Vữa",IF(SUMPRODUCT((ISNUMBER(FIND({"M50","M75","M100","M150","M200","M250","M300"},$C2)))*1),"LM: BT","")))
mà em cũng dốt thật thầy ạ ( Sử dụng 2 vòng lặp). Chỉ cần lồng 1 vòng lặp của thầy là được rồi. Hì hì
Mã:Public Sub GPE_EPG() Application.ScreenUpdating = False Dim sArr(), dArr(1 To 1000, 1 To 7), i As Long, j As Long, k As Long, R As Long With Sheets("List BB") sArr = .Range("B3", .Range("B3").End(xlDown)).Resize(, 7).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, 7): dArr(k, 3) = "Nthu: " & sArr(i, 1) dArr(k, 4) = sArr(i, 2): dArr(k, 5) = sArr(i, 3) Next i With Sheets("GPE") .Range("A2").Resize(1000, 5).ClearContents .Range("C2").Resize(1000, 3).Font.ColorIndex = 0 .Range("A2:G65535").Borders.LineStyle = xlNone .Range("A2:G65535").Font.Underline = xlUnderlineStyleNone If k Then .Range("A2").Resize(k, 5) = dArr .Range("B2").Resize(k, 4).Sort Key1:=.Range("B2") .Range("A2").Resize(k, 7).Borders.LineStyle = xlContinuous .Range("A2").Resize(k, 7).Borders(xlInsideHorizontal).Weight = xlHairline 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 .Range("C" & i).Characters(Start:=1, Length:=5).Font.Underline = xlUnderlineStyleSingle End If If .Range("B" & i) <> Empty Then With .Range("A" & i & ":G" & i).Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin End With End If Next i Thoitiet .PageSetup.PrintArea = "$A$1:$G$" & k + 1 End If End With Application.ScreenUpdating = True End Sub
Lần chỉnh sửa cuối:
Upvote
0
PacificPR
Thành viên mới
- Tham gia
- 6/5/16
- Bài viết
- 1,997
- Được thích
- 2,750
- Trong VBA không hiểu tiếng Việt nên công thức trên không ra được kết quả
- Bạn xem file thử nha. Mình tạo thêm 2 mảng phụ ( Loại mẫu và Mác)
(Sao hôm nay lại không đính kèm được file vậy)
LinK: http://www.mediafire.com/file/4bzfbw1dx2z3ame/NhatKy1.xlsm
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
a viêt dùm em đoạn code tự dãn dòng khi dòng dài quá, và tự co dòng nữa!
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
À vâng em thấy rồi ạ.. Thanks kiu anh nhiều! em test thử chút có ji mắc lại phiền bác ^^!
Upvote
0
PacificPR
Thành viên mới
- Tham gia
- 6/5/16
- Bài viết
- 1,997
- Được thích
- 2,750
Mã:
With Sheets("GPE") Loaimau = .Range("M2", .Range("M2").End(xlDown)).Value
Mac = .Range("N2", .Range("N2").End(xlDown)).Value
End With
Mã:
For L = 1 To UBound(Loaimau, 1)
If UCase(sArr(i, 1)) Like "*" & UCase(Loaimau(L, 1)) & "*" Then
For m = 1 To UBound(Mac, 1)
If UCase(sArr(i, 1)) Like UCase("*" & Mac(m, 1) & "*") Then
dArr(k, 6) = "LM: " & Loaimau(L, 1) & " " & Mac(m, 1)
End If
Next m
End If
Next L
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
Mình có thể giới hạn chiều co lại bé nhất là 16 được không anh nhỉ
Upvote
0
alibaba2209
Thành viên thường trực
- Tham gia
- 4/12/10
- Bài viết
- 283
- Được thích
- 13
cảm ơn anh nhiều ạ! code
như này đúng chưa a nhỉ
Upvote
0
Bài viết mới nhất
- Question