Nhóm theo phòng ban có điều kiện (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)
V

vanlinh_2904

Thành viên hoạt động
Tham gia
20/10/12
Bài viết
117
Được thích
3
Chào các anh chị,
Mình nhờ các anh chị viết giúp VBA để nhóm các nhân viên theo phòng ban và tự động điền ngày làm việc của tháng dựa vào mã nhân viên và ngày ký hợp đồng ở sheet " Nhap lieu". cho các sheet T1,T2, T3..., T12 như file đính kèm. Cảm ơn các anh chị ạ.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
(1) + "ngày bắt đầu hợp đồng" < ngày cuối cùng của tháng, thì bỏ qua mã nhân viên đó và không đưa vào danh sách
. . . .
(2) + Ngày đầu tiên của tháng < "ngày bắt đầu hợp đồng" < ngày cuối cùng của tháng, thì kết quả cột F là "ngày bắt đầu hợp đồng" ở sheet "Nhap lieu";. . .
Nhấp chuột vào đây để mở rộng...
Hai điều này có gì đó không ổn lắm!
 
Upvote 0
vanlinh_2904 đã viết:
Chào các anh chị,
Mình nhờ các anh chị viết giúp VBA để nhóm các nhân viên theo phòng ban và tự động điền ngày làm việc của tháng dựa vào mã nhân viên và ngày ký hợp đồng ở sheet " Nhap lieu". cho các sheet T1,T2, T3..., T12 như file đính kèm. Cảm ơn các anh chị ạ.
Nhấp chuột vào đây để mở rộng...
Mục đích bạn làm ra 12 sheets để làm gì vậy.Sao không làm 1 sheets thôi rồi điền tháng và năm vào là được dữ liệu.Có nhất thiết phải 12 sheets không.
 
Upvote 0
SA_DQ đã viết:
Hai điều này có gì đó không ổn lắm!
Nhấp chuột vào đây để mở rộng...
Xin lỗi bạn nhé, mình đã sửa lại
(1) + "ngày bắt đầu hợp đồng" > ngày cuối cùng của tháng
(2) + Ngày đầu tiên của tháng < "ngày bắt đầu hợp đồng" , thì kết quả cột F là "ngày bắt đầu hợp đồng"
Bài đã được tự động gộp:

snow25 đã viết:
Mục đích bạn làm ra 12 sheets để làm gì vậy.Sao không làm 1 sheets thôi rồi điền tháng và năm vào là được dữ liệu.Có nhất thiết phải 12 sheets không.
Nhấp chuột vào đây để mở rộng...
Vì bảng lương cho nhân viên thường tính theo tháng để khi mở lên cho dễ xem đó bạn.
 

File đính kèm

Upvote 0
PHP: 
Option Explicit

Sub vData()


Dim i, j, k, l, intL, intD, intTMP, edRow, edRowC, intKQ, l2KQ As Integer
Dim SArr, Result, PhongBan, KQ
Dim ws As Worksheet
Dim DicT As Dictionary

Application.ScreenUpdating = False
intKQ = 0
Set DicT = New Scripting.Dictionary
SArr = Sheet1.Range("B6:F" & Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row).Value
ReDim Result(1 To UBound(SArr, 1), 1 To UBound(SArr, 2))

Set ws = ActiveSheet
For intL = 1 To UBound(SArr, 1) - 1
    If Month(SArr(intL, 4)) = Month(ws.Range("F2").Value) And Month(SArr(intL, 5)) = Month(ws.Range("G2").Value) Then
    If Not Day(SArr(intL, 4) > Day(ws.Range("G2").Value)) Then
         If Not Day(SArr(intL, 5) < Day(ws.Range("F2").Value)) Then
            If Day(ws.Range("F2").Value) < Day(SArr(intL, 4)) And Day(SArr(intL, 5)) < Day(ws.Range("G2").Value) Then
                intD = intD + 1
                 Result(intD, 1) = SArr(intL, 1)
                 Result(intD, 2) = SArr(intL, 2)
                 Result(intD, 3) = SArr(intL, 3)
                 Result(intD, 4) = SArr(intL, 4)
                 Result(intD, 5) = SArr(intL, 5)
            ElseIf Day(ws.Range("F2").Value) > Day(SArr(intL, 4)) And Day(SArr(intL, 5)) > Day(ws.Range("G2").Value) Then
                 intD = intD + 1
                 Result(intD, 1) = SArr(intL, 1)
                 Result(intD, 2) = SArr(intL, 2)
                 Result(intD, 3) = SArr(intL, 3)
                 Result(intD, 4) = ws.Range("F2").Value
                 Result(intD, 5) = ws.Range("G2").Value
          End If
        End If
    End If
End If
Next
ReDim KQ(1 To UBound(Result, 1), 1 To UBound(Result, 2))
ReDim PhongBan(1 To 4, 1 To 1)
    For i = 1 To UBound(Result, 1)
        If Not DicT.Exists(Result(i, 3)) Then
            j = j + 1
            DicT.Add Result(i, 3), j
            PhongBan(j, 1) = Result(i, 3)
        End If
    Next
For k = 1 To UBound(PhongBan, 1)
    intD = 0
    For l = 1 To UBound(Result, 1)
        If PhongBan(k, 1) = Result(l, 3) Then
            With ActiveSheet
                edRow = Cells(Rows.Count, "C").End(xlUp).Row
            End With
            intD = intD + 1
                If Not Cells(edRow, 2).Value = PhongBan(k, 1) Then
            Cells(edRow + 1, 2) = PhongBan(k, 1)
                Else
                End If
            Cells(edRow + 1, 3) = Result(l, 1)
            Cells(edRow + 1, 4) = Result(l, 2)
            Cells(edRow + 1, 5) = Result(l, 3)
            Cells(edRow + 1, 6) = Result(l, 4)
            Cells(edRow + 1, 7) = Result(l, 5)
        End If
    Next
Next

Application.ScreenUpdating = True

Bạn thử chạy xem đúng ý chưa
 
Upvote 0
huuquy1196 đã viết:
PHP: 
Option Explicit

Sub vData()


Dim i, j, k, l, intL, intD, intTMP, edRow, edRowC, intKQ, l2KQ As Integer
Dim SArr, Result, PhongBan, KQ
Dim ws As Worksheet
Dim DicT As Dictionary

Application.ScreenUpdating = False
intKQ = 0
Set DicT = New Scripting.Dictionary
SArr = Sheet1.Range("B6:F" & Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row).Value
ReDim Result(1 To UBound(SArr, 1), 1 To UBound(SArr, 2))

Set ws = ActiveSheet
For intL = 1 To UBound(SArr, 1) - 1
    If Month(SArr(intL, 4)) = Month(ws.Range("F2").Value) And Month(SArr(intL, 5)) = Month(ws.Range("G2").Value) Then
    If Not Day(SArr(intL, 4) > Day(ws.Range("G2").Value)) Then
         If Not Day(SArr(intL, 5) < Day(ws.Range("F2").Value)) Then
            If Day(ws.Range("F2").Value) < Day(SArr(intL, 4)) And Day(SArr(intL, 5)) < Day(ws.Range("G2").Value) Then
                intD = intD + 1
                 Result(intD, 1) = SArr(intL, 1)
                 Result(intD, 2) = SArr(intL, 2)
                 Result(intD, 3) = SArr(intL, 3)
                 Result(intD, 4) = SArr(intL, 4)
                 Result(intD, 5) = SArr(intL, 5)
            ElseIf Day(ws.Range("F2").Value) > Day(SArr(intL, 4)) And Day(SArr(intL, 5)) > Day(ws.Range("G2").Value) Then
                 intD = intD + 1
                 Result(intD, 1) = SArr(intL, 1)
                 Result(intD, 2) = SArr(intL, 2)
                 Result(intD, 3) = SArr(intL, 3)
                 Result(intD, 4) = ws.Range("F2").Value
                 Result(intD, 5) = ws.Range("G2").Value
          End If
        End If
    End If
End If
Next
ReDim KQ(1 To UBound(Result, 1), 1 To UBound(Result, 2))
ReDim PhongBan(1 To 4, 1 To 1)
    For i = 1 To UBound(Result, 1)
        If Not DicT.Exists(Result(i, 3)) Then
            j = j + 1
            DicT.Add Result(i, 3), j
            PhongBan(j, 1) = Result(i, 3)
        End If
    Next
For k = 1 To UBound(PhongBan, 1)
    intD = 0
    For l = 1 To UBound(Result, 1)
        If PhongBan(k, 1) = Result(l, 3) Then
            With ActiveSheet
                edRow = Cells(Rows.Count, "C").End(xlUp).Row
            End With
            intD = intD + 1
                If Not Cells(edRow, 2).Value = PhongBan(k, 1) Then
            Cells(edRow + 1, 2) = PhongBan(k, 1)
                Else
                End If
            Cells(edRow + 1, 3) = Result(l, 1)
            Cells(edRow + 1, 4) = Result(l, 2)
            Cells(edRow + 1, 5) = Result(l, 3)
            Cells(edRow + 1, 6) = Result(l, 4)
            Cells(edRow + 1, 7) = Result(l, 5)
        End If
    Next
Next

Application.ScreenUpdating = True

Bạn thử chạy xem đúng ý chưa
Nhấp chuột vào đây để mở rộng...
Bạn xem giúp mình bị lỗi thế này.
1587717548539.png
 
Upvote 0
vanlinh_2904 đã viết:
Chào các anh chị,
Mình nhờ các anh chị viết giúp VBA để nhóm các nhân viên theo phòng ban và tự động điền ngày làm việc của tháng dựa vào mã nhân viên và ngày ký hợp đồng ở sheet " Nhap lieu". cho các sheet T1,T2, T3..., T12 như file đính kèm. Cảm ơn các anh chị ạ.
Nhấp chuột vào đây để mở rộng...
Bạn thử code sau thêm 1 sheets mau.
Mã: 
Sub tach()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim arr, i As Long, sh As Worksheet, lr As Long, dk As String, a As Long, b As Long, s As String, kq, ten, m As Long, dic As Object
    Dim ngaycuoi As Date, ngaydau As Date, T, j As Long, c As Integer
    Set dic = CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Nhap lieu" And sh.Name <> "Mau" Then
           sh.Delete
        End If
    Next sh
    With Sheets("Nhap lieu")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr < 6 Then Exit Sub
         arr = .Range("B6:F" & lr).Value
         m = UBound(arr)
         ReDim ten(1 To m)
         For i = 1 To m
             s = arr(i, 3) & "#" & Month(arr(i, 4))
             If Not dic.exists(s) Then
                dic.Add s, i
             Else
                dic.Item(s) = dic.Item(s) & "#" & i
             End If
             If Not dic.exists(arr(i, 3)) Then
                a = a + 1
                dic.Add arr(i, 3), ""
                ten(a) = arr(i, 3)
             End If
         Next i
   End With
       For i = 1 To 12
           b = 0
           ReDim kq(1 To m, 1 To 6)
           Set sh = Sheets.Add(After:=Sheets(Sheets.Count))
           sh.Name = "T" & i
           ngaydau = DateSerial(2020, i, 1)
           ngaycuoi = DateSerial(2020, i + 1, 0)
           sh.Range("F1").Value = "Thang " & i
           sh.Range("F2").Value = ngaydau
           sh.Range("G2").Value = ngaycuoi
           sh.Range("b4:G5").Value = Sheets("mau").Range("b4:G5").Value
           For j = 1 To a
               s = ten(j) & "#" & i
               If dic.exists(s) Then
                  c = 0
                  b = b + 1
                  kq(b, 1) = ten(j)
                  For Each T In Split(dic.Item(s), "#")
                      c = c + 1
                      b = b + 1
                      kq(b, 1) = c
                      kq(b, 2) = arr(T, 1)
                      kq(b, 3) = arr(T, 2)
                      kq(b, 4) = arr(T, 3)
                      kq(b, 5) = arr(T, 4)
                      If Month(arr(T, 5)) = i Then
                         kq(b, 6) = arr(T, 5)
                      Else
                         kq(b, 6) = ngaycuoi
                      End If
                  Next
              End If
          Next j
          If b Then sh.Range("B6:G6").Resize(b).Value = kq
       Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 

File đính kèm

Upvote 0
huuquy1196 đã viết:
PHP: 
Option Explicit

Sub vData()


Dim i, j, k, l, intL, intD, intTMP, edRow, edRowC, intKQ, l2KQ As Integer
Dim SArr, Result, PhongBan, KQ
Dim ws As Worksheet
Dim DicT As Dictionary

Application.ScreenUpdating = False
intKQ = 0
Set DicT = New Scripting.Dictionary
SArr = Sheet1.Range("B6:F" & Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row).Value
ReDim Result(1 To UBound(SArr, 1), 1 To UBound(SArr, 2))

Set ws = ActiveSheet
For intL = 1 To UBound(SArr, 1) - 1
    If Month(SArr(intL, 4)) = Month(ws.Range("F2").Value) And Month(SArr(intL, 5)) = Month(ws.Range("G2").Value) Then
    If Not Day(SArr(intL, 4) > Day(ws.Range("G2").Value)) Then
         If Not Day(SArr(intL, 5) < Day(ws.Range("F2").Value)) Then
            If Day(ws.Range("F2").Value) < Day(SArr(intL, 4)) And Day(SArr(intL, 5)) < Day(ws.Range("G2").Value) Then
                intD = intD + 1
                 Result(intD, 1) = SArr(intL, 1)
                 Result(intD, 2) = SArr(intL, 2)
                 Result(intD, 3) = SArr(intL, 3)
                 Result(intD, 4) = SArr(intL, 4)
                 Result(intD, 5) = SArr(intL, 5)
            ElseIf Day(ws.Range("F2").Value) > Day(SArr(intL, 4)) And Day(SArr(intL, 5)) > Day(ws.Range("G2").Value) Then
                 intD = intD + 1
                 Result(intD, 1) = SArr(intL, 1)
                 Result(intD, 2) = SArr(intL, 2)
                 Result(intD, 3) = SArr(intL, 3)
                 Result(intD, 4) = ws.Range("F2").Value
                 Result(intD, 5) = ws.Range("G2").Value
          End If
        End If
    End If
End If
Next
ReDim KQ(1 To UBound(Result, 1), 1 To UBound(Result, 2))
ReDim PhongBan(1 To 4, 1 To 1)
    For i = 1 To UBound(Result, 1)
        If Not DicT.Exists(Result(i, 3)) Then
            j = j + 1
            DicT.Add Result(i, 3), j
            PhongBan(j, 1) = Result(i, 3)
        End If
    Next
For k = 1 To UBound(PhongBan, 1)
    intD = 0
    For l = 1 To UBound(Result, 1)
        If PhongBan(k, 1) = Result(l, 3) Then
            With ActiveSheet
                edRow = Cells(Rows.Count, "C").End(xlUp).Row
            End With
            intD = intD + 1
                If Not Cells(edRow, 2).Value = PhongBan(k, 1) Then
            Cells(edRow + 1, 2) = PhongBan(k, 1)
                Else
                End If
            Cells(edRow + 1, 3) = Result(l, 1)
            Cells(edRow + 1, 4) = Result(l, 2)
            Cells(edRow + 1, 5) = Result(l, 3)
            Cells(edRow + 1, 6) = Result(l, 4)
            Cells(edRow + 1, 7) = Result(l, 5)
        End If
    Next
Next

Application.ScreenUpdating = True

Bạn thử chạy xem đúng ý chưa
Nhấp chuột vào đây để mở rộng...
Bạn xem giúp mình tháng 1 chỉ hiện lên có 2 nhân viên, bạn xem kết quả như sheet "Mau" giúp mình nhé. Đồng thời mình làm để khi nhập liệu ở sheet "nhap lieu" thì bị lỗi. Nhờ bạn xem giúp mình nhé. Cảm ơn bạn nhiều
Bài đã được tự động gộp:

snow25 đã viết:
Bạn thử code sau thêm 1 sheets mau.
Mã: 
Sub tach()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim arr, i As Long, sh As Worksheet, lr As Long, dk As String, a As Long, b As Long, s As String, kq, ten, m As Long, dic As Object
    Dim ngaycuoi As Date, ngaydau As Date, T, j As Long, c As Integer
    Set dic = CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Nhap lieu" And sh.Name <> "Mau" Then
           sh.Delete
        End If
    Next sh
    With Sheets("Nhap lieu")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr < 6 Then Exit Sub
         arr = .Range("B6:F" & lr).Value
         m = UBound(arr)
         ReDim ten(1 To m)
         For i = 1 To m
             s = arr(i, 3) & "#" & Month(arr(i, 4))
             If Not dic.exists(s) Then
                dic.Add s, i
             Else
                dic.Item(s) = dic.Item(s) & "#" & i
             End If
             If Not dic.exists(arr(i, 3)) Then
                a = a + 1
                dic.Add arr(i, 3), ""
                ten(a) = arr(i, 3)
             End If
         Next i
   End With
       For i = 1 To 12
           b = 0
           ReDim kq(1 To m, 1 To 6)
           Set sh = Sheets.Add(After:=Sheets(Sheets.Count))
           sh.Name = "T" & i
           ngaydau = DateSerial(2020, i, 1)
           ngaycuoi = DateSerial(2020, i + 1, 0)
           sh.Range("F1").Value = "Thang " & i
           sh.Range("F2").Value = ngaydau
           sh.Range("G2").Value = ngaycuoi
           sh.Range("b4:G5").Value = Sheets("mau").Range("b4:G5").Value
           For j = 1 To a
               s = ten(j) & "#" & i
               If dic.exists(s) Then
                  c = 0
                  b = b + 1
                  kq(b, 1) = ten(j)
                  For Each T In Split(dic.Item(s), "#")
                      c = c + 1
                      b = b + 1
                      kq(b, 1) = c
                      kq(b, 2) = arr(T, 1)
                      kq(b, 3) = arr(T, 2)
                      kq(b, 4) = arr(T, 3)
                      kq(b, 5) = arr(T, 4)
                      If Month(arr(T, 5)) = i Then
                         kq(b, 6) = arr(T, 5)
                      Else
                         kq(b, 6) = ngaycuoi
                      End If
                  Next
              End If
          Next j
          If b Then sh.Range("B6:G6").Resize(b).Value = kq
       Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Nhấp chuột vào đây để mở rộng...
Nhờ bạn chỉnh giúp mình:
+ Như thời gian hợp đồng ở sheet"Nhap lieu" từ 05/01/2020 đến 25/02/2020 thì sheet "T2" nhân viên đó vẫn còn và ngày làm việc trong tháng là : 01/02/2020 đến 25/02/2020.
+ Như thời gian hợp đồng ở sheet"Nhap lieu" từ 04/01/2020 đến 15/12/2020 thì sheet "T2", T3,.. nhân viên đó vẫn còn và ngày làm việc tính tròn 1 tháng là : T2: 01/02/2020 đến 29/02/2020; T3: 01/03/2020 đến 31/03/2020; ...; T12: 01/12/2020 đến 15/12/2020.
Cảm ơn bạn nhé.
 
Lần chỉnh sửa cuối:
Upvote 0
huuquy1196 đã viết:
PHP: 
Option Explicit

Sub vData()


Dim i, j, k, l, intL, intD, intTMP, edRow, edRowC, intKQ, l2KQ As Integer
Dim SArr, Result, PhongBan, KQ
Dim ws As Worksheet
Dim DicT As Dictionary

Application.ScreenUpdating = False
intKQ = 0
Set DicT = New Scripting.Dictionary
SArr = Sheet1.Range("B6:F" & Sheet1.Cells(Sheet1.Rows.Count, "B").End(xlUp).Row).Value
ReDim Result(1 To UBound(SArr, 1), 1 To UBound(SArr, 2))

Set ws = ActiveSheet
For intL = 1 To UBound(SArr, 1) - 1
    If Month(SArr(intL, 4)) = Month(ws.Range("F2").Value) And Month(SArr(intL, 5)) = Month(ws.Range("G2").Value) Then
    If Not Day(SArr(intL, 4) > Day(ws.Range("G2").Value)) Then
         If Not Day(SArr(intL, 5) < Day(ws.Range("F2").Value)) Then
            If Day(ws.Range("F2").Value) < Day(SArr(intL, 4)) And Day(SArr(intL, 5)) < Day(ws.Range("G2").Value) Then
                intD = intD + 1
                 Result(intD, 1) = SArr(intL, 1)
                 Result(intD, 2) = SArr(intL, 2)
                 Result(intD, 3) = SArr(intL, 3)
                 Result(intD, 4) = SArr(intL, 4)
                 Result(intD, 5) = SArr(intL, 5)
            ElseIf Day(ws.Range("F2").Value) > Day(SArr(intL, 4)) And Day(SArr(intL, 5)) > Day(ws.Range("G2").Value) Then
                 intD = intD + 1
                 Result(intD, 1) = SArr(intL, 1)
                 Result(intD, 2) = SArr(intL, 2)
                 Result(intD, 3) = SArr(intL, 3)
                 Result(intD, 4) = ws.Range("F2").Value
                 Result(intD, 5) = ws.Range("G2").Value
          End If
        End If
    End If
End If
Next
ReDim KQ(1 To UBound(Result, 1), 1 To UBound(Result, 2))
ReDim PhongBan(1 To 4, 1 To 1)
    For i = 1 To UBound(Result, 1)
        If Not DicT.Exists(Result(i, 3)) Then
            j = j + 1
            DicT.Add Result(i, 3), j
            PhongBan(j, 1) = Result(i, 3)
        End If
    Next
For k = 1 To UBound(PhongBan, 1)
    intD = 0
    For l = 1 To UBound(Result, 1)
        If PhongBan(k, 1) = Result(l, 3) Then
            With ActiveSheet
                edRow = Cells(Rows.Count, "C").End(xlUp).Row
            End With
            intD = intD + 1
                If Not Cells(edRow, 2).Value = PhongBan(k, 1) Then
            Cells(edRow + 1, 2) = PhongBan(k, 1)
                Else
                End If
            Cells(edRow + 1, 3) = Result(l, 1)
            Cells(edRow + 1, 4) = Result(l, 2)
            Cells(edRow + 1, 5) = Result(l, 3)
            Cells(edRow + 1, 6) = Result(l, 4)
            Cells(edRow + 1, 7) = Result(l, 5)
        End If
    Next
Next

Application.ScreenUpdating = True

Bạn thử chạy xem đúng ý chưa
Nhấp chuột vào đây để mở rộng...
Bạn xem giúp mình tháng 1 chỉ hiện lên có 2 nhân viên, bạn xem kết quả như sheet "Mau" giúp mình nhé. Đồng thời mình làm để khi nhập liệu ở sheet "nhap lieu" thì bị lỗi. Nhờ bạn xem giúp mình nhé. Cảm ơn bạn nhiều
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
vanlinh_2904 đã viết:
Bạn xem giúp mình tháng 1 chỉ hiện lên có 2 nhân viên, bạn xem kết quả như sheet "Mau" giúp mình nhé. Đồng thời mình làm để khi nhập liệu ở sheet "nhap lieu" thì bị lỗi. Nhờ bạn xem giúp mình nhé. Cảm ơn bạn nhiều
Bài đã được tự động gộp:


Nhờ bạn chỉnh giúp mình:
+ Như thời gian hợp đồng ở sheet"Nhap lieu" từ 05/01/2020 đến 25/02/2020 thì sheet "T2" nhân viên đó vẫn còn và ngày làm việc trong tháng là : 01/02/2020 đến 25/02/2020.
+ Như thời gian hợp đồng ở sheet"Nhap lieu" từ 04/01/2020 đến 15/12/2020 thì sheet "T2", T3,.. nhân viên đó vẫn còn và ngày làm việc tính tròn 1 tháng là : T2: 01/02/2020 đến 29/02/2020; T3: 01/03/2020 đến 31/03/2020; ...; T12: 01/12/2020 đến 15/12/2020.
Cảm ơn bạn nhé.
Nhấp chuột vào đây để mở rộng...
Bạn thử code này nhé.
Mã: 
Sub tach()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim arr, i As Long, sh As Worksheet, lr As Long, dk As String, a As Long, b As Long, s As String, kq, ten, m As Long, dic As Object
    Dim ngaycuoi As Date, ngaydau As Date, T, j As Long, c As Integer, thangdau As Integer, thangcuoi As Integer, k As Long, data
    Set dic = CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Nhap lieu" And sh.Name <> "Mau" Then
           sh.Delete
        End If
    Next sh
    With Sheets("Nhap lieu")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr < 6 Then Exit Sub
         arr = .Range("B6:F" & lr).Value
         m = UBound(arr)
         ReDim data(1 To m * 12, 1 To 5)
         ReDim ten(1 To m)
         For i = 1 To m
             thangdau = Month(arr(i, 4))
             thangcuoi = Month(arr(i, 5))
             For b = thangdau To thangcuoi
                 k = k + 1
                 ngaydau = DateSerial(2020, b, 1)
                 ngaycuoi = DateSerial(2020, b + 1, 0)
                 data(k, 1) = arr(i, 1)
                 data(k, 2) = arr(i, 2)
                 data(k, 3) = arr(i, 3)
                 If b = thangdau Then data(k, 4) = arr(i, 4) Else data(k, 4) = ngaydau
                 If b = thangcuoi Then data(k, 5) = arr(i, 5) Else data(k, 5) = ngaycuoi
                 s = data(k, 3) & "#" & b
                 If Not dic.exists(s) Then
                    dic.Add s, k
                 Else
                    dic.Item(s) = dic.Item(s) & "#" & k
                 End If
            Next b
                If Not dic.exists(arr(i, 3)) Then
                   a = a + 1
                  dic.Add arr(i, 3), ""
                  ten(a) = arr(i, 3)
                End If
         Next i
   End With
       For i = 1 To 12
           b = 0
           ReDim kq(1 To k, 1 To 6)
           Set sh = Sheets.Add(After:=Sheets(Sheets.Count))
           sh.Name = "T" & i
            thangdau = Month(arr(i, 4))
            thangcuoi = Month(arr(i, 5))
           sh.Range("F1").Value = "Thang " & i
           sh.Range("F2").Value = ngaydau
           sh.Range("G2").Value = ngaycuoi
           sh.Range("b4:G5").Value = Sheets("mau").Range("b4:G5").Value
           For j = 1 To a
               s = ten(j) & "#" & i
               If dic.exists(s) Then
                  c = 0
                  b = b + 1
                  kq(b, 1) = ten(j)
                  For Each T In Split(dic.Item(s), "#")
                      c = c + 1
                      b = b + 1
                      kq(b, 1) = c
                      kq(b, 2) = data(T, 1)
                      kq(b, 3) = data(T, 2)
                      kq(b, 4) = data(T, 3)
                      kq(b, 5) = data(T, 4)
                      kq(b, 6) = data(T, 5)
                  Next
              End If
          Next j
          If b Then sh.Range("B6:G6").Resize(b).Value = kq
       Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Upvote 0
snow25 đã viết:
Bạn thử code này nhé.
Mã: 
Sub tach()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim arr, i As Long, sh As Worksheet, lr As Long, dk As String, a As Long, b As Long, s As String, kq, ten, m As Long, dic As Object
    Dim ngaycuoi As Date, ngaydau As Date, T, j As Long, c As Integer, thangdau As Integer, thangcuoi As Integer, k As Long, data
    Set dic = CreateObject("scripting.dictionary")
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Nhap lieu" And sh.Name <> "Mau" Then
           sh.Delete
        End If
    Next sh
    With Sheets("Nhap lieu")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr < 6 Then Exit Sub
         arr = .Range("B6:F" & lr).Value
         m = UBound(arr)
         ReDim data(1 To m * 12, 1 To 5)
         ReDim ten(1 To m)
         For i = 1 To m
             thangdau = Month(arr(i, 4))
             thangcuoi = Month(arr(i, 5))
             For b = thangdau To thangcuoi
                 k = k + 1
                 ngaydau = DateSerial(2020, b, 1)
                 ngaycuoi = DateSerial(2020, b + 1, 0)
                 data(k, 1) = arr(i, 1)
                 data(k, 2) = arr(i, 2)
                 data(k, 3) = arr(i, 3)
                 If b = thangdau Then data(k, 4) = arr(i, 4) Else data(k, 4) = ngaydau
                 If b = thangcuoi Then data(k, 5) = arr(i, 5) Else data(k, 5) = ngaycuoi
                 s = data(k, 3) & "#" & b
                 If Not dic.exists(s) Then
                    dic.Add s, k
                 Else
                    dic.Item(s) = dic.Item(s) & "#" & k
                 End If
            Next b
                If Not dic.exists(arr(i, 3)) Then
                   a = a + 1
                  dic.Add arr(i, 3), ""
                  ten(a) = arr(i, 3)
                End If
         Next i
   End With
       For i = 1 To 12
           b = 0
           ReDim kq(1 To k, 1 To 6)
           Set sh = Sheets.Add(After:=Sheets(Sheets.Count))
           sh.Name = "T" & i
            thangdau = Month(arr(i, 4))
            thangcuoi = Month(arr(i, 5))
           sh.Range("F1").Value = "Thang " & i
           sh.Range("F2").Value = ngaydau
           sh.Range("G2").Value = ngaycuoi
           sh.Range("b4:G5").Value = Sheets("mau").Range("b4:G5").Value
           For j = 1 To a
               s = ten(j) & "#" & i
               If dic.exists(s) Then
                  c = 0
                  b = b + 1
                  kq(b, 1) = ten(j)
                  For Each T In Split(dic.Item(s), "#")
                      c = c + 1
                      b = b + 1
                      kq(b, 1) = c
                      kq(b, 2) = data(T, 1)
                      kq(b, 3) = data(T, 2)
                      kq(b, 4) = data(T, 3)
                      kq(b, 5) = data(T, 4)
                      kq(b, 6) = data(T, 5)
                  Next
              End If
          Next j
          If b Then sh.Range("B6:G6").Resize(b).Value = kq
       Next i
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn nhiều nhé, kết quả đúng rồi bạn, nhưng mình muốn cố định các sheet T1 đến T12 (đã tạo trước), bạn giúp mình nhé.
 
Upvote 0
vanlinh_2904 đã viết:
Chào các anh chị,
Mình nhờ các anh chị viết giúp VBA để nhóm các nhân viên theo phòng ban và tự động điền ngày làm việc của tháng dựa vào mã nhân viên và ngày ký hợp đồng ở sheet " Nhap lieu". cho các sheet T1,T2, T3..., T12 như file đính kèm. Cảm ơn các anh chị ạ.
Nhấp chuột vào đây để mở rộng...
Code chưa bẩy lổi dữ liệu nhập lung tung
Phải nhập năm vào sheet "Mau"
Xem thiết kế các sheet trong file
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), tArr() As Date, Arr, Res(), Dic As Object, iKey$
  Dim eRow&, sRow&, t&, i&, N&, k&, j&, stt&, Nam&, fMonth&, eMonth&
  Dim fDay As Date, eDay As Date, fYear As Date, eYear As Date
 
  On Error Resume Next
  Application.ScreenUpdating = False
  With Sheets("Nhap lieu")
    Nam = Sheets("Mau").Range("C2").Value
  End With
  fYear = DateSerial(Nam, 1, 1): eYear = DateSerial(Nam, 12, 31)
 
  With Sheets("Nhap lieu")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    Arr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Sort .Range("D6"), 1, .Range("B6"), , 1, Header:=xlNo
    sArr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Value = Arr
  End With
 
  sRow = UBound(sArr)
  ReDim Arr(0 To sRow + 2, 1 To 6)
  N = UBound(Arr)
  ReDim Res(1 To 12)
  ReDim tArr(1 To 12, 1 To 2)
 
  For t = 1 To 12
    Res(t) = Arr
    tArr(t, 1) = DateSerial(Nam, t, 1)
    tArr(t, 2) = DateSerial(Nam, t + 1, 1) - 1
    With Sheets("T" & t)
      .Range("F2") = tArr(t, 1)
      .Range("G2") = tArr(t, 2)
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow > 5 Then .Range("B6:G" & eRow).ClearContents
    End With
  Next t

  For i = 1 To sRow
    fDay = sArr(i, 4): eDay = sArr(i, 5)
    If fDay <= eYear And eDay >= fYear Then
      If fDay < fYear Then fDay = fYear
      If eDay > eYear Then eDay = eYear
      fMonth = Month(fDay): eMonth = Month(eDay)
      For t = fMonth To eMonth
        k = Res(t)(N, 1) + 1:       Res(t)(N, 1) = k
        Res(t)(k, 2) = sArr(i, 1): Res(t)(k, 3) = sArr(i, 2): Res(t)(k, 4) = sArr(i, 3)
        If fDay > tArr(t, 1) Then Res(t)(k, 5) = fDay Else Res(t)(k, 5) = tArr(t, 1)
        If eDay < tArr(t, 2) Then Res(t)(k, 6) = eDay Else Res(t)(k, 6) = tArr(t, 2)
      Next t
    End If
  Next i
 
  For t = 1 To 12
    If Res(t)(N, 1) <> Empty Then
      k = 0
      ReDim Arr(1 To Res(t)(N, 1) * 2, 1 To 6)
      For i = 1 To N - 2
        If Res(t)(i, 2) = Empty Then
          Sheets("T" & t).Range("B6").Resize(k, 6) = Arr
          Exit For
        End If
        If Res(t)(i, 4) <> Res(t)(i - 1, 4) Then
          k = k + 1: stt = 0
          Arr(k, 1) = Res(t)(i, 4)
        End If
        k = k + 1
        stt = stt + 1
        Arr(k, 1) = stt
        For j = 2 To 6
          Arr(k, j) = Res(t)(i, j)
        Next j
      Next i
    End If
  Next t
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

Upvote 0
HieuCD đã viết:
Code chưa bẩy lổi dữ liệu nhập lung tung
Phải nhập năm vào sheet "Mau"
Xem thiết kế các sheet trong file
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), tArr() As Date, Arr, Res(), Dic As Object, iKey$
  Dim eRow&, sRow&, t&, i&, N&, k&, j&, stt&, Nam&, fMonth&, eMonth&
  Dim fDay As Date, eDay As Date, fYear As Date, eYear As Date

  On Error Resume Next
  Application.ScreenUpdating = False
  With Sheets("Nhap lieu")
    Nam = Sheets("Mau").Range("C2").Value
  End With
  fYear = DateSerial(Nam, 1, 1): eYear = DateSerial(Nam, 12, 31)

  With Sheets("Nhap lieu")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    Arr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Sort .Range("D6"), 1, .Range("B6"), , 1, Header:=xlNo
    sArr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Value = Arr
  End With

  sRow = UBound(sArr)
  ReDim Arr(0 To sRow + 2, 1 To 6)
  N = UBound(Arr)
  ReDim Res(1 To 12)
  ReDim tArr(1 To 12, 1 To 2)

  For t = 1 To 12
    Res(t) = Arr
    tArr(t, 1) = DateSerial(Nam, t, 1)
    tArr(t, 2) = DateSerial(Nam, t + 1, 1) - 1
    With Sheets("T" & t)
      .Range("F2") = tArr(t, 1)
      .Range("G2") = tArr(t, 2)
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow > 5 Then .Range("B6:G" & eRow).ClearContents
    End With
  Next t

  For i = 1 To sRow
    fDay = sArr(i, 4): eDay = sArr(i, 5)
    If fDay <= eYear And eDay >= fYear Then
      If fDay < fYear Then fDay = fYear
      If eDay > eYear Then eDay = eYear
      fMonth = Month(fDay): eMonth = Month(eDay)
      For t = fMonth To eMonth
        k = Res(t)(N, 1) + 1:       Res(t)(N, 1) = k
        Res(t)(k, 2) = sArr(i, 1): Res(t)(k, 3) = sArr(i, 2): Res(t)(k, 4) = sArr(i, 3)
        If fDay > tArr(t, 1) Then Res(t)(k, 5) = fDay Else Res(t)(k, 5) = tArr(t, 1)
        If eDay < tArr(t, 2) Then Res(t)(k, 6) = eDay Else Res(t)(k, 6) = tArr(t, 2)
      Next t
    End If
  Next i

  For t = 1 To 12
    If Res(t)(N, 1) <> Empty Then
      k = 0
      ReDim Arr(1 To Res(t)(N, 1) * 2, 1 To 6)
      For i = 1 To N - 2
        If Res(t)(i, 2) = Empty Then
          Sheets("T" & t).Range("B6").Resize(k, 6) = Arr
          Exit For
        End If
        If Res(t)(i, 4) <> Res(t)(i - 1, 4) Then
          k = k + 1: stt = 0
          Arr(k, 1) = Res(t)(i, 4)
        End If
        k = k + 1
        stt = stt + 1
        Arr(k, 1) = stt
        For j = 2 To 6
          Arr(k, j) = Res(t)(i, j)
        Next j
      Next i
    End If
  Next t
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Nhờ bạn sửa giúp mình những chữ phòng ban như : Quản lý, Kế Toán, Kinh Doanh,... ở cột B các tháng định dạng FontStyle = "Bold", cảm ơn bạn
 
Upvote 0
vanlinh_2904 đã viết:
Nhờ bạn sửa giúp mình những chữ phòng ban như : Quản lý, Kế Toán, Kinh Doanh,... ở cột B các tháng định dạng FontStyle = "Bold", cảm ơn bạn
Nhấp chuột vào đây để mở rộng...
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), tArr() As Date, Arr, Res(), S, iStr$
  Dim eRow&, sRow&, t&, i&, N&, k&, j&, r&, stt&, Nam&, fMonth&, eMonth&
  Dim fDay As Date, eDay As Date, fYear As Date, eYear As Date
 
  On Error Resume Next
  Application.ScreenUpdating = False
  With Sheets("Nhap lieu")
    Nam = Sheets("Mau").Range("C2").Value
  End With
  fYear = DateSerial(Nam, 1, 1): eYear = DateSerial(Nam, 12, 31)
 
  With Sheets("Nhap lieu")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    Arr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Sort .Range("D6"), 1, .Range("B6"), , 1, Header:=xlNo
    sArr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Value = Arr
  End With
 
  sRow = UBound(sArr)
  ReDim Arr(0 To sRow + 2, 1 To 6)
  N = UBound(Arr)
  ReDim Res(1 To 12)
  ReDim tArr(1 To 12, 1 To 2)
 
  For t = 1 To 12
    Res(t) = Arr
    tArr(t, 1) = DateSerial(Nam, t, 1)
    tArr(t, 2) = DateSerial(Nam, t + 1, 1) - 1
    With Sheets("T" & t)
      .Range("F2") = tArr(t, 1)
      .Range("G2") = tArr(t, 2)
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow > 5 Then .Range("B6:G" & eRow).Clear
    End With
  Next t

  For i = 1 To sRow
    fDay = sArr(i, 4): eDay = sArr(i, 5)
    If fDay <= eYear And eDay >= fYear Then
      If fDay < fYear Then fDay = fYear
      If eDay > eYear Then eDay = eYear
      fMonth = Month(fDay): eMonth = Month(eDay)
      For t = fMonth To eMonth
        k = Res(t)(N, 1) + 1:       Res(t)(N, 1) = k
        Res(t)(k, 2) = sArr(i, 1): Res(t)(k, 3) = sArr(i, 2): Res(t)(k, 4) = sArr(i, 3)
        If fDay > tArr(t, 1) Then Res(t)(k, 5) = fDay Else Res(t)(k, 5) = tArr(t, 1)
        If eDay < tArr(t, 2) Then Res(t)(k, 6) = eDay Else Res(t)(k, 6) = tArr(t, 2)
      Next t
    End If
  Next i
 
  For t = 1 To 12
    If Res(t)(N, 1) <> Empty Then
      k = 0: iStr = Empty
      ReDim Arr(1 To Res(t)(N, 1) * 2, 1 To 6)
      For i = 1 To N - 2
        If Res(t)(i, 2) = Empty Then
          With Sheets("T" & t)
            .Range("B6").Resize(k, 6) = Arr
            S = Split(iStr, ",")
            For r = 1 To UBound(S)
              .Range("B" & S(r)).Font.Bold = True
            Next r
          End With
          Exit For
        End If
        If Res(t)(i, 4) <> Res(t)(i - 1, 4) Then
          k = k + 1: stt = 0: iStr = iStr & "," & k + 5
          Arr(k, 1) = Res(t)(i, 4)
        End If
        k = k + 1
        stt = stt + 1
        Arr(k, 1) = stt
        For j = 2 To 6
          Arr(k, j) = Res(t)(i, j)
        Next j
      Next i
    End If
  Next t
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), tArr() As Date, Arr, Res(), S, iStr$
  Dim eRow&, sRow&, t&, i&, N&, k&, j&, r&, stt&, Nam&, fMonth&, eMonth&
  Dim fDay As Date, eDay As Date, fYear As Date, eYear As Date

  On Error Resume Next
  Application.ScreenUpdating = False
  With Sheets("Nhap lieu")
    Nam = Sheets("Mau").Range("C2").Value
  End With
  fYear = DateSerial(Nam, 1, 1): eYear = DateSerial(Nam, 12, 31)

  With Sheets("Nhap lieu")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    Arr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Sort .Range("D6"), 1, .Range("B6"), , 1, Header:=xlNo
    sArr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Value = Arr
  End With

  sRow = UBound(sArr)
  ReDim Arr(0 To sRow + 2, 1 To 6)
  N = UBound(Arr)
  ReDim Res(1 To 12)
  ReDim tArr(1 To 12, 1 To 2)

  For t = 1 To 12
    Res(t) = Arr
    tArr(t, 1) = DateSerial(Nam, t, 1)
    tArr(t, 2) = DateSerial(Nam, t + 1, 1) - 1
    With Sheets("T" & t)
      .Range("F2") = tArr(t, 1)
      .Range("G2") = tArr(t, 2)
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow > 5 Then .Range("B6:G" & eRow).Clear
    End With
  Next t

  For i = 1 To sRow
    fDay = sArr(i, 4): eDay = sArr(i, 5)
    If fDay <= eYear And eDay >= fYear Then
      If fDay < fYear Then fDay = fYear
      If eDay > eYear Then eDay = eYear
      fMonth = Month(fDay): eMonth = Month(eDay)
      For t = fMonth To eMonth
        k = Res(t)(N, 1) + 1:       Res(t)(N, 1) = k
        Res(t)(k, 2) = sArr(i, 1): Res(t)(k, 3) = sArr(i, 2): Res(t)(k, 4) = sArr(i, 3)
        If fDay > tArr(t, 1) Then Res(t)(k, 5) = fDay Else Res(t)(k, 5) = tArr(t, 1)
        If eDay < tArr(t, 2) Then Res(t)(k, 6) = eDay Else Res(t)(k, 6) = tArr(t, 2)
      Next t
    End If
  Next i

  For t = 1 To 12
    If Res(t)(N, 1) <> Empty Then
      k = 0: iStr = Empty
      ReDim Arr(1 To Res(t)(N, 1) * 2, 1 To 6)
      For i = 1 To N - 2
        If Res(t)(i, 2) = Empty Then
          With Sheets("T" & t)
            .Range("B6").Resize(k, 6) = Arr
            S = Split(iStr, ",")
            For r = 1 To UBound(S)
              .Range("B" & S(r)).Font.Bold = True
            Next r
          End With
          Exit For
        End If
        If Res(t)(i, 4) <> Res(t)(i - 1, 4) Then
          k = k + 1: stt = 0: iStr = iStr & "," & k + 5
          Arr(k, 1) = Res(t)(i, 4)
        End If
        k = k + 1
        stt = stt + 1
        Arr(k, 1) = stt
        For j = 2 To 6
          Arr(k, j) = Res(t)(i, j)
        Next j
      Next i
    End If
  Next t
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Chào bạn, hôm trước mình có nhờ bạn viết code này nhưng có xíu trục trặc nhờ bạn sửa giúp mình. Nếu ở cột E các ngày có cùng tháng 01 thì sheet"T1" lại bị lỗi không có dữ liệu. Bạn xem file đính kèm nhé. Cảm ơn bạn nhiều
 

File đính kèm

Upvote 0
vanlinh_2904 đã viết:
Chào bạn, hôm trước mình có nhờ bạn viết code này nhưng có xíu trục trặc nhờ bạn sửa giúp mình. Nếu ở cột E các ngày có cùng tháng 01 thì sheet"T1" lại bị lỗi không có dữ liệu. Bạn xem file đính kèm nhé. Cảm ơn bạn nhiều
Nhấp chuột vào đây để mở rộng...
Chỉnh lại tí tẹo
Mã: 
Option Explicit
Sub XYZ()
  Dim sArr(), tArr() As Date, Arr, Res(), S, iStr$
  Dim eRow&, sRow&, t&, i&, N&, k&, j&, r&, stt&, Nam&, fMonth&, eMonth&
  Dim fDay As Date, eDay As Date, fYear As Date, eYear As Date
 
  On Error Resume Next
  Application.ScreenUpdating = False
  With Sheets("Nhap lieu")
    Nam = Sheets("Mau").Range("C2").Value
  End With
  fYear = DateSerial(Nam, 1, 1): eYear = DateSerial(Nam, 12, 31)
 
  With Sheets("Nhap lieu")
    eRow = .Range("B" & Rows.Count).End(xlUp).Row
    Arr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Sort .Range("D6"), 1, .Range("B6"), , 1, Header:=xlNo
    sArr = .Range("B6:F" & eRow).Value
    .Range("B6:F" & eRow).Value = Arr
  End With
 
  sRow = UBound(sArr)
  ReDim Arr(0 To sRow + 2, 1 To 6)
  N = UBound(Arr)
  ReDim Res(1 To 12)
  ReDim tArr(1 To 12, 1 To 2)
 
  For t = 1 To 12
    Res(t) = Arr
    tArr(t, 1) = DateSerial(Nam, t, 1)
    tArr(t, 2) = DateSerial(Nam, t + 1, 1) - 1
    With Sheets("T" & t)
      .Range("F2") = tArr(t, 1)
      .Range("G2") = tArr(t, 2)
      eRow = .Range("C" & Rows.Count).End(xlUp).Row
      If eRow > 5 Then .Range("B6:G" & eRow).Clear
    End With
  Next t

  For i = 1 To sRow
    fDay = sArr(i, 4): eDay = sArr(i, 5)
    If fDay <= eYear And eDay >= fYear Then
      If fDay < fYear Then fDay = fYear
      If eDay > eYear Then eDay = eYear
      fMonth = Month(fDay): eMonth = Month(eDay)
      For t = fMonth To eMonth
        k = Res(t)(N, 1) + 1:       Res(t)(N, 1) = k
        Res(t)(k, 2) = sArr(i, 1): Res(t)(k, 3) = sArr(i, 2): Res(t)(k, 4) = sArr(i, 3)
        If fDay > tArr(t, 1) Then Res(t)(k, 5) = fDay Else Res(t)(k, 5) = tArr(t, 1)
        If eDay < tArr(t, 2) Then Res(t)(k, 6) = eDay Else Res(t)(k, 6) = tArr(t, 2)
      Next t
    End If
  Next i
 
  For t = 1 To 12
    If Res(t)(N, 1) <> Empty Then
      k = 0: iStr = Empty
      ReDim Arr(1 To Res(t)(N, 1) * 2, 1 To 6)
      For i = 1 To N - 1  'Chinh N-2 thành N-1
        If Res(t)(i, 2) = Empty Then
          With Sheets("T" & t)
            .Range("B6").Resize(k, 6) = Arr
            S = Split(iStr, ",")
            For r = 1 To UBound(S)
              .Range("B" & S(r)).Font.Bold = True
            Next r
          End With
          Exit For
        End If
        If Res(t)(i, 4) <> Res(t)(i - 1, 4) Then
          k = k + 1: stt = 0: iStr = iStr & "," & k + 5
          Arr(k, 1) = Res(t)(i, 4)
        End If
        k = k + 1
        stt = stt + 1
        Arr(k, 1) = stt
        For j = 2 To 6
          Arr(k, j) = Res(t)(i, j)
        Next j
      Next i
    End If
  Next t
  Application.ScreenUpdating = True
End Sub
 
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

ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (10 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
4 5 6
Trả lời
556
Đọc
72K
sát thủ uyên ương
S
C
Fix lỗi Application.InputBox Type:=8 (2 người xem)
    • Cười
Trả lời
6
Đọc
102
SA_DQ
SA_DQ
Emyeuexcel
Tham chiếu về 1 ô-lấy ra và lọc dữ liệu
Trả lời
5
Đọc
91
Emyeuexcel
Emyeuexcel
L
Hỏi lỗi excel bị tràn trang khi in (1 người xem)
Trả lời
3
Đọc
68
Hoàng Tuấn 868
H
E
  • Question Question
VBA tự động thay đổi tham chiếu vùng (range và cell) khi insert dòng cột trong sheet tính toán
    • Cười
Trả lời
5
Đọc
122
eagle12
E
D
Tổng hợp dữ liệu từ các sheet sang sheet tổng
Trả lời
3
Đọc
146
dohungmo
D
T
font chu trong excel
Trả lời
2
Đọc
71
Hoàng Tuấn 868
H
khuong182018
  • Question Question
Nhờ anh chị sửa lỗi setfocus ở textbox
Trả lời
9
Đọc
163
khuong182018
khuong182018
N
File chia băng tự động từ cuộn mẹ theo khổ băng và khối lượng băng cho trước
Trả lời
0
Đọc
42
nguyenanhtruong2409
N
SA_DQ
Copilot bình luận về một ván cờ vua (1 người xem)
Trả lời
0
Đọc
74
SA_DQ
SA_DQ
T
Xin giúp đỡ lọc dữ liệu
    • Cười
Trả lời
4
Đọc
114
pycckuu410
pycckuu410
Nguyễn Duy Tuân
[New] BSAC v3.0 bộ công cụ lập trình phần mềm chuyên nghiệp trong VBA
    • Thích
Trả lời
13
Đọc
4K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Code Sổ Chi Tiết Tài Khoản
Trả lời
8
Đọc
328
hieuvietmy2020
H
befaint
Chia sẻ tâm tư, xả nỗi lòng (5 người xem)
    • Thích
6 7 8
Trả lời
778
Đọc
75K
SA_DQ
SA_DQ
H
Chia sẻ file in Phiếu điều tra PCGD
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
12
Đọc
442
HUONGHCKT
H
V
Hỏi công thức để làm khối lượng trong xây dựng. Xin cảm ơn
Trả lời
11
Đọc
522
phanphu_91
P
Linhnv0001
Hỏi - Cách kiểm tra laptop là hàng lắp ráp hay không
Trả lời
3
Đọc
275
Lê Duy Thương
Lê Duy Thương
K
Nhờ anh chị làm công thức lọc dữ kiện ngày từ bảng 1 sang rút gọn ngày ở bảng 2.
Trả lời
2
Đọc
186
Lê Duy Thương
Lê Duy Thương
L
[Mẹo] Không chọn Add-in vẫn có thể sử dụng được chức năng của Add-in, giảm tốc độ loading của Excel.
    • Thích
Trả lời
2
Đọc
498
HeSanbi
HeSanbi
GPE-Trợ Lý
[GPE18] KỸ THUẬT BIỂU ĐỒ NÂNG CAO CHO DASHBOARD: TRỰC QUAN HÓA TIẾN ĐỘ THỰC HIỆN KẾ HOẠCH
    • Thích
Trả lời
2
Đọc
9K
ptm0412
ptm0412
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