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

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
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.
Web KT

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

N
Xin giúp e cách lọc dữ liệu bị trùng (5 người xem)
Trả lời
1
Đọc
32
hoangtuaotrang_hp_vn
H
SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng (2 người xem)
Trả lời
2
Đọc
42
vanthinh3101
vanthinh3101
MaxanB
Cần hỗ trợ công thức Vlookup nhiều sheet theo điều kiên (2 người xem)
Trả lời
1
Đọc
34
Duy Tùng 9x
Duy Tùng 9x
tonny jj
Lập hàm thể hiện số công lệnh của ngày đi công tác (1 người xem)
Trả lời
8
Đọc
215
Nguyễn Nal
N
H
chuyển dữ liệu từ 1 dòng thành nhiều dòng,
Trả lời
13
Đọc
134
Duy Tùng 9x
Duy Tùng 9x
K
Hỏi lỗi không kéo được công thức (Ctrl+D) (1 người xem)
Trả lời
7
Đọc
113
khoinguyen2024
K
C
Filter có điều kiện đang ở dạng Cột
Trả lời
3
Đọc
107
Chí Còn Phí
C
H
Quản Lý Công Văn đi Và đến (1 người xem)
9 10 11
Trả lời
216
Đọc
159K
dungnguyenMNCK
D
Nguyễn Duy Tuân
Hướng dẫn lập trình với Google Sheets và Excel Online bằng Excel VBA và Add-in A-Tools v10
    • Thích
Trả lời
10
Đọc
564
Nguyễn Duy Tuân
Nguyễn Duy Tuân
dongbhhg
Tìm lương cơ sở theo từng tháng (1 người xem)
Trả lời
2
Đọc
54
Duy Tùng 9x
Duy Tùng 9x
Quách Ngọc
Trả về kết quả ngày tháng hay khoảng trống
Trả lời
2
Đọc
34
Duy Tùng 9x
Duy Tùng 9x
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA (1 người xem)
Trả lời
6
Đọc
7K
ngocbinh.no.kia
N
Vũ Thị Thuý Ly
Em xin nhờ các anh chị trên diễn đàn giúp đỡ viết hàm hoặc VBA tính tổng các giá trị theo điều kiện (1 người xem)
Trả lời
3
Đọc
45
bebo021999
B
DinhManh1307
Cách thống kê công việc sản xuất từng người để tính lương sản phẩm (2 người xem)
Trả lời
16
Đọc
264
DinhManh1307
DinhManh1307
V
Làm mẫu giấy đi đường (công lệnh) bằng Excel
Trả lời
10
Đọc
11K
SA_DQ
SA_DQ
B
Xin hướng dẫn cách để hàm Xlookup tự hiển thị theo số dòng có chứa điều kiện tìm kiếm ko dùng VBA
Trả lời
9
Đọc
129
thuytrangbp28
T
V
Help: Hàm đếm lọc giá trị trùng
    • Cười
Trả lời
17
Đọc
140
SA_DQ
SA_DQ
R
Chuyển count thành sum khi pivot
Trả lời
4
Đọc
8K
ptm0412
ptm0412
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Cười
Trả lời
2
Đọc
94
TramAnhNguyen692
T
S
NHỜ ANH EM GIÚP MÌNH TÌM KIẾM DỮ LIỆU
Trả lời
12
Đọc
163
sangdennh
S
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom