Nhờ các a viết cho đoạn code cho file (1 người xem)

Elx Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
A

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"
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
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
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
Sharava36 đã viết:
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
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
Nhấp chuột vào đây để mở rộng...
code bị lỗi. Bạn xem dùm lại chút
 
Upvote 0
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
 
Upvote 0
Sharava36 đã viết:
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
Nhấp chuột vào đây để mở rộng...
[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]
Nhấp chuột vào đây để mở rộng...
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]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ấp chuột vào đây để mở rộng...
 
Upvote 0
alibaba2209 đã viết:
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ấp chuột vào đây để mở rộng...

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é.
 

File đính kèm

Upvote 0
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
 
Upvote 0
Ba Tê đã viết:
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é.
Nhấp chuột vào đây để mở rộng...
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
Sharava36 đã viết:
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
Nhấp chuột vào đây để mở rộng...
Dạ vâng! em cảm ơn.. file demo thôi anh ạ
 
Upvote 0
alibaba2209 đã viết:
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 ạ
Nhấp chuột vào đây để mở rộng...
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
Sharava36 đã viết:
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
Nhấp chuột vào đây để mở rộng...
Vâng em cảm ơn nhiều ạ!
 
Upvote 0
Sharava36 đã viết:
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
Nhấp chuột vào đây để mở rộng...
Anh ơi còn khóa Vùng in nữa ạ..phiền anh tý nữa!
 
Upvote 0
Sharava36 đã viết:
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 ạ
Nhấp chuột vào đây để mở rộng...

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
Ba Tê đã viết:
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
Nhấp chuột vào đây để mở rộng...
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.
Chúc thầy mạnh khỏe
 
Upvote 0
alibaba2209 đã viết:
Anh ơi còn khóa Vùng in nữa ạ..phiền anh tý nữa!
Nhấp chuột vào đây để mở rộng...
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
Sharava36 đã viết:
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...!$@!!
Nhấp chuột vào đây để mở rộng...
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ỉ!
 
Upvote 0
Ba Tê đã viết:
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
Nhấp chuột vào đây để mở rộng...
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
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
Nhấp chuột vào đây để mở rộng...
1.jpg 2.jpge xóa 2 cột đi giờ phải đổi code như nào a nhỉ
 
Upvote 0
alibaba2209 đã viết:
e xóa 2 cột đi giờ phải đổi code như nào a nhỉ
Nhấp chuột vào đây để mở rộng...
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
Sharava36 đã viết:
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
Nhấp chuột vào đây để mở rộng...

Hì hì..........
Người ta chuẩn bị 3 cái nút (chỉ xem hình chứ chưa thấy mặt mũi), bạn "gom" lại thì thiếu chỗ "ấn nút" rồi.
 
Upvote 0
Ba Tê đã viết:
Hì hì..........
Người ta chuẩn bị 3 cái nút (chỉ xem hình chứ chưa thấy mặt mũi), bạn "gom" lại thì thiếu chỗ "ấn nút" rồi.
Nhấp chuột vào đây để mở rộng...
-=.,, 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
Sharava36 đã viết:
-=.,, 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ì
....................
Nhấp chuột vào đây để mở rộng...
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.
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
Em chân thành cảm ơn các thầy, các a đã giúp đỡ.. để thử code ạ!
 
Upvote 0
Sharava36 đã viết:
-=.,, 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
Nhấp chuột vào đây để mở rộng...
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","")))
 
Lần chỉnh sửa cuối:
Upvote 0
alibaba2209 đã viết:
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","")))
Nhấp chuột vào đây để mở rộng...
- 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
Upvote 0
alibaba2209 đã viết:
À 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 ^^!
Nhấp chuột vào đây để mở rộng...

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
Sharava36 đã viết:
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
Nhấp chuột vào đây để mở rộng...
cảm ơn anh nhiều ạ! code
.Range("A2").Resize(k, 7).RowHeight = 22
Nhấp chuột vào đây để mở rộng...
như này đúng chưa a nhỉ
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

P
Hyperlink_Cách chuyển cả thư mục và file tổng hợp sang máy khác không bị lỗi (2 người xem)
Trả lời
2
Đọc
39
phong_kid
P
HeSanbi
Tiện ích Web: Tự động nhấn nút "Bỏ qua" quảng cáo Youtube
    • Thích
    • Yêu thích
Trả lời
14
Đọc
1K
ongke0711
ongke0711
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
55
Đọc
22K
Gà Con yêu VBA
Gà Con yêu VBA
C
Fix lỗi Application.InputBox Type:=8 (1 người xem)
    • Cười
Trả lời
20
Đọc
541
cdshtz88
C
ptm0412
Quá tin tưởng vào AI các thể loại
    • Cười
Trả lời
4
Đọc
146
Maika8008
Maika8008
A
  • Question Question
Không tìm được lỗi code
Trả lời
6
Đọc
92
ptm0412
ptm0412
SA_DQ
Copilot bình luận về một ván cờ vua
    • Thích
Trả lời
5
Đọc
370
SA_DQ
SA_DQ
W
Tham chiếu theo chuỗi ký tự
Trả lời
8
Đọc
286
dungpham01
D
tritv.dad
Lấy dữ liệu từ folder các tờ khai thông quan để theo dõi hiệu suất công việc. (1 người xem)
Trả lời
8
Đọc
254
BlueSphere
B
GPE-Trợ Lý
MỪNG NGÀY NHÀ GIÁO VIỆT NAM 20/11 (1 người xem)
    • Thích
Trả lời
0
Đọc
753
GPE-Trợ Lý
GPE-Trợ Lý
SA_DQ
Xin chúc mừng các thầy cô giáo trên cộng đồng nhân 20/11
    • Thích
    • Yêu thích
Trả lời
1
Đọc
109
BuiQuangThuan
B
M
chuyển đổi số thành chữ
Trả lời
15
Đọc
292
dungpham01
D
V
Lỗi copy sheet: the name already exists.
Trả lời
7
Đọc
680
nghiabros
N
L
Nhờ hỗ trợ tìm hàm excel trả về giá trị (1 người xem)
Trả lời
4
Đọc
118
lechuong174
L
SA_DQ
Copilot & giúp hỗ trợ nhập các ký tự đặt biệt
    • Thích
Trả lời
0
Đọc
80
SA_DQ
SA_DQ
GPE-Trợ Lý
[GPE20] BIỂU ĐỒ CHUYÊN NGHIỆP: PHÁ VỠ GIỚI HẠN 2 TRỤC CỦA EXCEL (1 người xem)
    • Thích
    • Yêu thích
Trả lời
1
Đọc
4K
GPE-Trợ Lý
GPE-Trợ Lý
hadu8889
EXCEL TỰ ĐỘNG ĐÓNG KHI SỬA TEXT Ở TRÊN USERFORM
Trả lời
10
Đọc
250
LOGANWover
L
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (3 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
565
Đọc
78K
lacmatquan
L
H
Lấy giá trị format trong ô của excel
Trả lời
2
Đọc
171
LOGANWover
L
A
Tìm nơi học VBA uy tín
    • Cười
Trả lời
2
Đọc
161
SA_DQ
SA_DQ
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom