Tạo phiếu giao việc cho từng nhân viên dựa trên Bảng dữ liệu tổng

quyenpv · 1/4/20

Thủ tướng cho cách ly Encovy toàn quốc mà bị trưởng phòng giao việc khó quá so với trình độ hiểu biết của mình nên mong anh chị hỗ trợ qua giai đoạn Encovy này với ạ
Tình hình là em hàng tháng đều phải làm bảng dữ liệu tổng để anh em trong phòng chạy việc theo yêu cầu của trưởng phòng em theo Sheet "GV-KTHT". Nay tự dưng bắt từ Sheet "GV-KTHT" hàng tháng đó đưa dữ liệu vào từng Sheet cho nhân viên để ký giữa TP và NV đánh giá hàng tháng
Cụ thể:
- Tạo từng Sheet cho nhân viên với tên từng người: VD Giaoviec_vuongdd1
- Kiểm tra dữ liệu cột L (Tiến độ) người nào thực hiện đưa dữ liệu vào từng Sheet của NV đó
- Tại Sheet Giaoviec_NV (VD "Giaoviec_vuongdd1) chi tiết lấy dữ liệu như sau:
+ Tên nhiệm vụ, công việc: Lấy dữ liệu cột B của Sheet GV-KTHT
+ Thời gian thực hiện: Lấy dữ liệu cột O của Sheet GV-KTHT
+ Mục tiêu, kết quả cần đạt được (Có thể đo lường được): Lấy dữ liệu cột E của Sheet GV-KTHT
+ Mức độ hoàn thành nhiệm vụ: Lấy dữ liệu cột F của Sheet GV-KTHT
Mong các anh chị giúp đỡ em với ạ

HieuCD · 11/2/21

quyenpv đã viết:
Hết rồi anh ạ. Nhờ anh giúp em với ạ

Kiểm tra lại

Mã:

Option Explicit

Sub XYZ2()
  Dim aTHKI(), aGV(), Res(), TD, Dic As Object, wB As Workbook
  Dim Rng As Range, RngFormat As Range, fDay As Date, eDay As Date
  Dim sRow&, i&, r&, k&, ik&, t&, Mail$, tmp
  Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean

  With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
    fDay = .Range("M3").Value: eDay = .Range("O3").Value
    If fDay = Empty Then fDay = DateValue("1000/1/1")
    If eDay = Empty Then eDay = DateValue("2100/1/1")
  End With
  With Sheets("TH KI")
    aTHKI = .Range("C8:M" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
  End With

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Sheets("Mau Giao viec").Copy
  Set wB = ActiveWorkbook
  With wB.Sheets("Mau Giao viec")
    Set Rng = .Range("A20:O25")
    Set RngFormat = .Range("A18:O18")
  End With

  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTHKI)
  For i = 1 To sRow
    If aTHKI(i, 1) <> Empty Then Dic.Item(aTHKI(i, 1)) = i
  Next i

  sRow = UBound(aGV)
For i = 1 To sRow
  tmp = aGV(i, 1)
  If tmp <> Empty And tmp <> "+" Then
    If IsNumeric(tmp) Then tR2 = i Else tR1 = i
  End If
  Mail = aGV(i, 12)
  If Mail <> Empty Then
    If fDay <= aGV(i, 15) And eDay >= aGV(i, 15) Then
      If Dic.exists(Mail & "#") = False Then
        Dic.Add Mail & "#", ""
        stt = 0: fR2 = tR2: bTd2 = True: fR1 = tR1: bTd1 = True
        ReDim Res(1 To sRow, 1 To 15)
        ReDim TD(1 To 20)  '***
        k = 0: t = 0
        For r = i To sRow
          tmp = aGV(r, 1)
          If tmp <> Empty And tmp <> "+" Then
            If IsNumeric(tmp) Then
              fR2 = r: bTd2 = True
            Else
              stt = 0: fR1 = r: bTd1 = True
            End If
          End If
          If aGV(r, 12) = Mail Then
            If bTd1 = True And fR1 > 0 Then '***
              k = k + 1:                bTd1 = False
              'Res(k, 1) = aGV(fR1, 1):  Res(k, 2) = aGV(fR1, 2)
              t = t + 1
              Res(k, 1) = Mid(Cells(1, t).Address(0, 0), 1, 1)
              TD(t) = k
              Res(k, 2) = aGV(fR1, 2)
            End If
            If bTd2 = True And fR2 > 0 Then
              k = k + 1:                bTd2 = False
              stt = stt + 1: Res(k, 1) = stt
              Res(k, 2) = aGV(fR2, 2)
            End If
            k = k + 1
            Res(k, 2) = aGV(r, 2)
            Res(k, 5) = aGV(r, 15)
            Res(k, 6) = aGV(r, 5)
            Res(k, 8) = aGV(r, 6)
          End If
        Next r
        wB.Sheets("Mau Giao viec").Copy After:=wB.Sheets(Sheets.Count)
        With wB.Sheets(Sheets.Count)
          .Name = "Giaoviec_" & Mail
          .Range("A20:O25").Clear
          ik = Dic.Item(Mail)
          If ik > 0 Then
            .Range("C5") = aTHKI(ik, 2):          .Range("C6") = Mail
            .Range("C7") = aTHKI(ik, 3):          .Range("C9") = aTHKI(ik, 4)
          End If
          If k Then
            .Range("A18").Resize(k, 15) = Res

          End If
          Rng.Copy .Range("A" & 18 + k)
          RngFormat.Copy
          If k > 3 Then .Range("A" & 20).Resize(k - 2, 15).PasteSpecial (xlPasteFormats)
          If k Then
            For r = 1 To t
              .Range("A" & TD(r) + 17).Resize(, 2).Font.Bold = True
            Next r
          End If
        End With
      End If
    End If
  End If
Next i
  wB.Sheets("Mau Giao viec").Delete
  ActiveWorkbook.Close True, ThisWorkbook.Path & "\GiaoViec" 'Luu voi tên File "GiaoViec"
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

quyenpv · 12/2/21

HieuCD đã viết:

Kiểm tra lại

Mã:

Option Explicit

Sub XYZ2()
  Dim aTHKI(), aGV(), Res(), TD, Dic As Object, wB As Workbook
  Dim Rng As Range, RngFormat As Range, fDay As Date, eDay As Date
  Dim sRow&, i&, r&, k&, ik&, t&, Mail$, tmp
  Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean

  With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
    fDay = .Range("M3").Value: eDay = .Range("O3").Value
    If fDay = Empty Then fDay = DateValue("1000/1/1")
    If eDay = Empty Then eDay = DateValue("2100/1/1")
  End With
  With Sheets("TH KI")
    aTHKI = .Range("C8:M" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
  End With

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Sheets("Mau Giao viec").Copy
  Set wB = ActiveWorkbook
  With wB.Sheets("Mau Giao viec")
    Set Rng = .Range("A20:O25")
    Set RngFormat = .Range("A18:O18")
  End With

  Set Dic = CreateObject("scripting.dictionary")
  sRow = UBound(aTHKI)
  For i = 1 To sRow
    If aTHKI(i, 1) <> Empty Then Dic.Item(aTHKI(i, 1)) = i
  Next i

  sRow = UBound(aGV)
For i = 1 To sRow
  tmp = aGV(i, 1)
  If tmp <> Empty And tmp <> "+" Then
    If IsNumeric(tmp) Then tR2 = i Else tR1 = i
  End If
  Mail = aGV(i, 12)
  If Mail <> Empty Then
    If fDay <= aGV(i, 15) And eDay >= aGV(i, 15) Then
      If Dic.exists(Mail & "#") = False Then
        Dic.Add Mail & "#", ""
        stt = 0: fR2 = tR2: bTd2 = True: fR1 = tR1: bTd1 = True
        ReDim Res(1 To sRow, 1 To 15)
        ReDim TD(1 To 20)  '***
        k = 0: t = 0
        For r = i To sRow
          tmp = aGV(r, 1)
          If tmp <> Empty And tmp <> "+" Then
            If IsNumeric(tmp) Then
              fR2 = r: bTd2 = True
            Else
              stt = 0: fR1 = r: bTd1 = True
            End If
          End If
          If aGV(r, 12) = Mail Then
            If bTd1 = True And fR1 > 0 Then '***
              k = k + 1:                bTd1 = False
              'Res(k, 1) = aGV(fR1, 1):  Res(k, 2) = aGV(fR1, 2)
              t = t + 1
              Res(k, 1) = Mid(Cells(1, t).Address(0, 0), 1, 1)
              TD(t) = k
              Res(k, 2) = aGV(fR1, 2)
            End If
            If bTd2 = True And fR2 > 0 Then
              k = k + 1:                bTd2 = False
              stt = stt + 1: Res(k, 1) = stt
              Res(k, 2) = aGV(fR2, 2)
            End If
            k = k + 1
            Res(k, 2) = aGV(r, 2)
            Res(k, 5) = aGV(r, 15)
            Res(k, 6) = aGV(r, 5)
            Res(k, 8) = aGV(r, 6)
          End If
        Next r
        wB.Sheets("Mau Giao viec").Copy After:=wB.Sheets(Sheets.Count)
        With wB.Sheets(Sheets.Count)
          .Name = "Giaoviec_" & Mail
          .Range("A20:O25").Clear
          ik = Dic.Item(Mail)
          If ik > 0 Then
            .Range("C5") = aTHKI(ik, 2):          .Range("C6") = Mail
            .Range("C7") = aTHKI(ik, 3):          .Range("C9") = aTHKI(ik, 4)
          End If
          If k Then
            .Range("A18").Resize(k, 15) = Res

          End If
          Rng.Copy .Range("A" & 18 + k)
          RngFormat.Copy
          If k > 3 Then .Range("A" & 20).Resize(k - 2, 15).PasteSpecial (xlPasteFormats)
          If k Then
            For r = 1 To t
              .Range("A" & TD(r) + 17).Resize(, 2).Font.Bold = True
            Next r
          End If
        End With
      End If
    End If
  End If
Next i
  wB.Sheets("Mau Giao viec").Delete
  ActiveWorkbook.Close True, ThisWorkbook.Path & "\GiaoViec" 'Luu voi tên File "GiaoViec"
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Em cám ơn anh rất nhiều, Code chuẩn rồi ạ

Tạo phiếu giao việc cho từng nhân viên dựa trên Bảng dữ liệu tổng

quyenpv

Thu nhặt kiến thức

File đính kèm

HieuCD

Chuyên gia GPE

quyenpv

Thu nhặt kiến thức

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

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