Nhờ lập công thức tổng hợp số nhân viên nghỉ theo từng thứ trong tuần (1 người xem)

[titanic20072007]

Xin chào ACE GPE.
Hôm nay mình có một tình huống cần ace giúp đỡ. Cụ thể mình có bảng dữ liệu tổng hợp ngày làm việc, ngày nghỉ của từng NV trong cơ quan. Giờ mình muốn tổng hợp theo tên tất cả nhân viên nghỉ theo từng thứ trong tuần để nhìn cho tiện nhưng làm không ra. Mình đưa lên nhờ ace giúp. Dữ liệu và mẫu trong tệp đính kèm. Cảm ơn mọi người.

 

[doatmenhhon]

Bài này rất hay nhưng mình nghĩ chắc phải làm bằng vba.

 

[doatmenhhon]

Chưa có thời gian tổng hợp cho ngắn hơn. Bạn dùng tạm. Ấn nút Run để chạy

 

[doatmenhhon]

Như vầy cho ngắn

Sub Tinh()
Dim i, j As Integer
For i = 5 To Sheets(1).[N65000].End(3).Row
  For j = 2 To 7
        If Range("N" & i) Like "*" & j & "*" Then
            Range("B" & 6 * j - 7) = Range("B" & 6 * j - 7) & vbNewLine & Range("J" & i)
        End If
   Next j
Next i
End Sub

Lời khuyên: Nên xuất sang sheet 2 để theo dõi

 

[titanic20072007]

Cảm ơn bạn doatmenhhon. Mình đã chạy thử cả hai đoạn code bạn viết đều cho ra kết quả chính xác. Tuy nhiên chạy hơi chậm bạn có thể chỉnh lại cho code chạy nhanh hơn được không.

 

[doatmenhhon]

Cảm ơn bạn doatmenhhon. Mình đã chạy thử cả hai đoạn code bạn viết đều cho ra kết quả chính xác. Tuy nhiên chạy hơi chậm bạn có thể chỉnh lại cho code chạy nhanh hơn được không.

Bạn dùng cách này mình test 5000 hàng cũng vài s. Nếu còn muốn nhanh nữa thì dùng mảng he he:

Sub Tinh()
Dim i, j As Integer
Application.ScreenUpdating = False
For i = 5 To Sheets(1).[N65000].End(3).Row
  For j = 2 To 7
        If Range("N" & i) Like "*" & j & "*" Then Range("B" & 6 * j - 7) = Range("B" & 6 * j - 7) & vbNewLine & Range("J" & i)
  Next j
Next i
Application.ScreenUpdating = True
End Sub

 

[titanic20072007]

Mình đã chuyển về mảng chạy nhanh hơn và đáp ứng được yêu cầu rồi.
Cách của hpkhuong mình không hiểu và phải đặt kq đúng như mẫu nên mình không chỉnh được.

Cảm ơn các bạn.

 

[concogia]

Bài của bạn doatmenhhon số vòng lặp còn thừa
Bài của bạn hpkhuong số vòng chạy ít nhất nhưng...."chơi" tới em "đít- to" thì ....ghê quá ( "chơi" bình thường cũng được mà), mà xem lại trong bài sao kết quả hình như còn thiếu
Híc

 

[doatmenhhon]

Bài của bạn doatmenhhon số vòng lặp còn thừa
Bài của bạn hpkhuong số vòng chạy ít nhất nhưng...."chơi" tới em "đít- to" thì ....ghê quá ( "chơi" bình thường cũng được mà), mà xem lại trong bài sao kết quả hình như còn thiếu
Híc

Cháu có thắc mắc là cháu dùng có 2 vòng thôi bằng bạn ấy sao mà nhiều hơn hay ít hơn hả bác Cò?

 

[concogia]

Cháu có thắc mắc là cháu dùng có 2 vòng thôi bằng bạn ấy sao mà nhiều hơn hay ít hơn hả bác Cò?

Code của bạn:

For i = 5 To Sheets(1).[N65000].End(3).Row
  For j = 2 To 7
        If Range("N" & i) Like "*" & j & "*" Then
            Range("B" & 6 * j - 7) = Range("B" & 6 * j - 7) & vbNewLine & Range("J" & i)
        End If
   Next j
Next i

Khi biến I chạy 1 lần thì biến J luôn luôn chạy 6 lần, nếu tách Range("N" & i) thành các phần tử nhỏ để chạy thì sẽ chạy ít hơn vì không ai nghỉ 6 ngày trong một tuần
Bạn í có tách ra bằng cách dùng Split, Replace, "Đít-to"......đó là cách làm.....cực kỳ phức tạp
Thân
Híc

 

[Ba Tê]

Code của bạn:

For i = 5 To Sheets(1).[N65000].End(3).Row
  For j = 2 To 7
        If Range("N" & i) Like "*" & j & "*" Then
            Range("B" & 6 * j - 7) = Range("B" & 6 * j - 7) & vbNewLine & Range("J" & i)
        End If
   Next j
Next i

Khi biến I chạy 1 lần thì biến J luôn luôn chạy 6 lần, nếu tách Range("N" & i) thành các phần tử nhỏ để chạy thì sẽ chạy ít hơn vì không ai nghỉ 6 ngày trong một tuần
Bạn í có tách ra bằng cách dùng Split, Replace, "Đít-to"......đó là cách làm.....cực kỳ phức tạp
Thân
Híc

Có cách nào dùng 1 vòng lặp không "Đại Ca" ?

 

[concogia]

Có cách nào dùng 1 vòng lặp không "Đại Ca" ?

Một vòng lặp không chưa biết, chỉ có đọc xong cái này...."mắc chết" quá:

 For J = 2 To Len(sArr(I, 5)) - 1 Step 2
        Thu = Mid(sArr(I, 5), J, 1)
[B]        If dArr(Thu - 1, 1) = Empty Then[/B]
[B]            dArr(Thu - 1, 1) = sArr(I, 1)[/B]
[B]        Else[/B]
[B]            dArr(Thu - 1, 1) = dArr(Thu - 1, 1) & Chr(10) & sArr(I, 1)[/B]
[B]        End If[/B]
    Next J

Sao lại phải IF nhỉ ??? Tóm được thằng Thu rồi thì gán nó luôn cho xong chuyện
Híc

 

[Ba Tê]

Một vòng lặp không chưa biết, chỉ có đọc xong cái này...."mắc chết" quá:

 For J = 2 To Len(sArr(I, 5)) - 1 Step 2
        Thu = Mid(sArr(I, 5), J, 1)
[B]        If dArr(Thu - 1, 1) = Empty Then[/B]
[B]            dArr(Thu - 1, 1) = sArr(I, 1)[/B]
[B]        Else[/B]
[B]            dArr(Thu - 1, 1) = dArr(Thu - 1, 1) & Chr(10) & sArr(I, 1)[/B]
[B]        End If[/B]
    Next J

Sao lại phải IF nhỉ ??? Tóm được thằng Thu rồi thì gán nó luôn cho xong chuyện
Híc

Híc!
Gán kiểu vậy rồi, kết quả sẽ có 1 thằng Chr(10) dzô dziên ở đầu hoặc cuối, không nghĩ ra cách nào đành phải IF.
Huhu...

 

[doatmenhhon]

Híc!
Gán kiểu vậy rồi, kết quả sẽ có 1 thằng Chr(10) dzô dziên ở đầu hoặc cuối, không nghĩ ra cách nào đành phải IF.
Huhu...

Cháu nghĩ nên sửa thành:

[FONT=arial]Sub GPE()[/FONT][FONT=arial]Dim sArr(), dArr(1 To 6, 1 To 1), i, j As Integer[/FONT]
[FONT=arial]sArr = Sheet1.Range("B5", Sheet1.Range("B5").End(xlDown)).Resize(, 5).Value[/FONT]
[FONT=arial]For i = 1 To UBound(sArr)[/FONT]
[FONT=arial]    For j = 1 To 6[/FONT]
[FONT=arial]         If sArr(i, 5) Like "*" & j + 1 & "*" Then dArr(j, 1) = dArr(j, 1) & vbNewLine & sArr(i, 1)[/FONT]
[FONT=arial]    Next j[/FONT]
[FONT=arial]Next i[/FONT]
[FONT=arial]Sheets("TH").Range("B5:B10") = dArr[/FONT]
[FONT=arial]End Sub

vì nếu dữ liệu luộm nhuộm thì chỉ cần thừa một dấu cách {2, 3, 4} hoặc thiếu một dấu ngoặc ví dụ 4,5,6} thì code không được như ý.[/FONT]

 

[Ba Tê]

Cháu nghĩ nên sửa thành:

[FONT=arial]Sub GPE()[/FONT][FONT=arial]Dim sArr(), dArr(1 To 6, 1 To 1), i, j As Integer[/FONT]
[FONT=arial]sArr = Sheet1.Range("B5", Sheet1.Range("B5").End(xlDown)).Resize(, 5).Value[/FONT]
[FONT=arial]For i = 1 To UBound(sArr)[/FONT]
[FONT=arial]    For j = 1 To 6[/FONT]
[FONT=arial]         If sArr(i, 5) Like "*" & j + 1 & "*" Then dArr(j, 1) = dArr(j, 1) & vbNewLine & sArr(i, 1)[/FONT]
[FONT=arial]    Next j[/FONT]
[FONT=arial]Next i[/FONT]
[FONT=arial]Sheets("TH").Range("B5:B10") = dArr[/FONT]
[FONT=arial]End Sub

vì nếu dữ liệu luộm nhuộm thì chỉ cần thừa một dấu cách {2, 3, 4} hoặc thiếu một dấu ngoặc ví dụ 4,5,6} thì code không được như ý.[/FONT]

- Đồng ý.
Nhưng với "móc giò" của anh Cò thì .... I chạy 1, J phải chạy 6, phí của, vì không phải ai cũng cần phải chạy từ 1-6, nên tôi né chuyện này.
Còn vbNewline hay Chr(10) cũng thế thôi,cuối cùng cũng dư 1 cái "Alt_Enter" ở đâu đó. trong kết quả.
(Code của bạn sẽ có 1 thăng "Atl+Enter" phía trước)
- Thiếu dấu "{}" hay thừa "{}" thì tác giả chịu trách nhiệm với dữ liệu của mình, trừ khi người hỏi báo trước những tình huống "luộm thuộm" xảy ra.

 

[doatmenhhon]

- Đồng ý.
Nhưng với "móc giò" của anh Cò thì .... I chạy 1, J phải chạy 6, phí của, vì không phải ai cũng cần phải chạy từ 1-6, nên tôi né chuyện này.
Còn vbNewline hay Chr(10) cũng thế thôi,cuối cùng cũng dư 1 cái "Alt_Enter" ở đâu đó. trong kết quả.
(Code của bạn sẽ có 1 thăng "Atl+Enter" phía trước)
- Thiếu dấu "{}" hay thừa "{}" thì tác giả chịu trách nhiệm với dữ liệu của mình, trừ khi người hỏi báo trước những tình huống "luộm thuộm" xảy ra.

Bác thật cẩn thận quá. Từng câu từng ý đều có một dụng ý thâm sâu. Cháu nghĩ chắc phải dùng regex thì cẩn thẩn hơn nữa

Sub GPE()
Dim sArr(), dArr(1 To 6, 1 To 1), I, J As Long, kq
sArr = Sheet1.Range("B5", Sheet1.Range("B65000").End(3)).Resize(, 5).Value
With CreateObject("vbscript.regexp")
    .Global = True
    .Pattern = "\d"
    For I = 1 To UBound(sArr)
         If .test(sArr(I, 5)) Then Set kq = .Execute(sArr(I, 5))
         For J = 0 To kq.Count - 1
            If dArr(kq(J) - 1, 1) = Empty Then
            dArr(kq(J) - 1, 1) = sArr(I, 1)
            Else
                dArr(kq(J) - 1, 1) = dArr(kq(J) - 1, 1) & Chr(10) & sArr(I, 1)
            End If
        Next J
    Next I
End With
Sheets("TH").Range("B5:B10") = dArr
End Sub