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 (1 người xem)

  • Thread starter Thread starter quyenpv
  • Ngày gửi Ngày gửi
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)
quyenpv

quyenpv

Thu nhặt kiến thức
Tham gia
5/1/13
Bài viết
729
Được thích
97
Giới tính
Nam
Nghề nghiệp
Decode cuộc đời!
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 ạ
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Mã: 
Option Explicit
Option Private Module
Sub Run_BB_2B()

    Dim i, k, ar, ketqua
    Dim Nguon, Dong
    Dim LastRow
    
    Dim MaCT, MaDT, BBBG, NgayBG, DiaBan

    With Sheets("GV-KTHT")
        Dong = .Range("O17").End(xlDown).Row
        Nguon = .Range("B11", "R" & Dong)                          'Cot cuoi cung tai Sheet Input_TB
        Dong = UBound(Nguon)
    End With

    ReDim ketqua(1 To Dong, 1 To 15)
    
    For i = 1 To Dong
      If Nguon(i, 11) = "vuongdd1" Then       'Ktra lay nhung vat tu DVSD
            k = k + 1
            ketqua(k, 1) = k
            ketqua(k, 2) = Nguon(i, 1)
            ketqua(k, 4) = 1
            ketqua(k, 6) = Nguon(i, 14)          'Ten VTTB
            ketqua(k, 7) = Nguon(i, 4)          'Ma VT
            ketqua(k, 8) = Nguon(i, 6)          'So luong nghiem thu
            ketqua(k, 9) = Nguon(i, 4)          'Don gia

      End If
    Next i


    Sheets("Giaoviec_vuongdd1").Select
    With Sheets("Giaoviec_vuongdd1")
       LastRow = Sheets("Giaoviec_vuongdd1").Cells(Rows.Count, "P").End(xlUp).Row

       If LastRow > 18 Then
          .Rows("18:" & LastRow - 1).Delete Shift:=xlShiftUp
       Else
          .Range("A18:K" & LastRow).ClearContents
       End If

      .Range("A18:A" & 18 + k - 1).EntireRow.Insert

      .Range("A18").Resize(k, 15).Value = ketqua

      .Range("C18:F" & 18 + k - 1).WrapText = 1
      .Range("C18:F" & 18 + k - 1).HorizontalAlignment = xlJustify
      .Range("A18:M" & 18 + k - 1).Font.Bold = False
      .Range("A18").Resize(k, 15).Borders.LineStyle = 1
      .Range("H18:J" & 18 + k + 1).NumberFormat = "#,##0.00"
      .Range("J" & 18 + k + 1).Formula = "=SUBTOTAL(9,J18:J" & 18 + k & ")"
      'Can chinh
      .Rows("18:" & LastRow - 1 & "").RowHeight = 35
      .Rows("" & LastRow & ":" & LastRow + 4 & "").RowHeight = 23
      .PageSetup.PrintArea = "$A$1:$M" & LastRow + 4 & ""
      
    End With
End Sub
Bài đã được tự động gộp:

Em viết code bước 1 trên test thử 1 người nhưng đang báo lỗi dòng
.Range("A18").Resize(k, 15).Value = ketqua
Các anh xem giúp em với ạ
 
Lần chỉnh sửa cuối:
Upvote 0
quyenpv đã viết:
Mã: 
Option Explicit
Option Private Module
Sub Run_BB_2B()

    Dim i, k, ar, ketqua
    Dim Nguon, Dong
    Dim LastRow
   
    Dim MaCT, MaDT, BBBG, NgayBG, DiaBan

    With Sheets("GV-KTHT")
        Dong = .Range("O17").End(xlDown).Row
        Nguon = .Range("B11", "R" & Dong)                          'Cot cuoi cung tai Sheet Input_TB
        Dong = UBound(Nguon)
    End With

    ReDim ketqua(1 To Dong, 1 To 15)
   
    For i = 1 To Dong
      If Nguon(i, 11) = "vuongdd1" Then       'Ktra lay nhung vat tu DVSD
            k = k + 1
            ketqua(k, 1) = k
            ketqua(k, 2) = Nguon(i, 1)
            ketqua(k, 4) = 1
            ketqua(k, 6) = Nguon(i, 14)          'Ten VTTB
            ketqua(k, 7) = Nguon(i, 4)          'Ma VT
            ketqua(k, 8) = Nguon(i, 6)          'So luong nghiem thu
            ketqua(k, 9) = Nguon(i, 4)          'Don gia

      End If
    Next i


    Sheets("Giaoviec_vuongdd1").Select
    With Sheets("Giaoviec_vuongdd1")
       LastRow = Sheets("Giaoviec_vuongdd1").Cells(Rows.Count, "P").End(xlUp).Row

       If LastRow > 18 Then
          .Rows("18:" & LastRow - 1).Delete Shift:=xlShiftUp
       Else
          .Range("A18:K" & LastRow).ClearContents
       End If

      .Range("A18:A" & 18 + k - 1).EntireRow.Insert

      .Range("A18").Resize(k, 15).Value = ketqua

      .Range("C18:F" & 18 + k - 1).WrapText = 1
      .Range("C18:F" & 18 + k - 1).HorizontalAlignment = xlJustify
      .Range("A18:M" & 18 + k - 1).Font.Bold = False
      .Range("A18").Resize(k, 15).Borders.LineStyle = 1
      .Range("H18:J" & 18 + k + 1).NumberFormat = "#,##0.00"
      .Range("J" & 18 + k + 1).Formula = "=SUBTOTAL(9,J18:J" & 18 + k & ")"
      'Can chinh
      .Rows("18:" & LastRow - 1 & "").RowHeight = 35
      .Rows("" & LastRow & ":" & LastRow + 4 & "").RowHeight = 23
      .PageSetup.PrintArea = "$A$1:$M" & LastRow + 4 & ""
     
    End With
End Sub
Bài đã được tự động gộp:

Em viết code bước 1 trên test thử 1 người nhưng đang báo lỗi dòng
.Range("A18").Resize(k, 15).Value = ketqua
Các anh xem giúp em với ạ
Nhấp chuột vào đây để mở rộng...
Bạn thử sửa thành thế này xem dòng này của bạn còn lỗi không
If K <> 0 then .Range("A18").Resize(k, 15).Value = ketqua
 
Upvote 0
Không lỗi nhưng không ra kết quả. Hic (@$%@
 
Upvote 0
quyenpv đã viết:
Không lỗi nhưng không ra kết quả. Hic (@$%@
Nhấp chuột vào đây để mở rộng...
Chỗ phần dữ liệu bạn sửa thành thế này xem
Mã: 
   With Sheets("GV-KTHT")
       Dong = Range("B" & Rows.Count).End(xlUp).Row
        Nguon = .Range("B17:R" & Dong)                          'Cot cuoi cung tai Sheet Input_TB
        Dong = UBound(Nguon)
    End With
 
Upvote 0
vanaccex đã viết:
Chỗ phần dữ liệu bạn sửa thành thế này xem
Mã: 
   With Sheets("GV-KTHT")
       Dong = Range("B" & Rows.Count).End(xlUp).Row
        Nguon = .Range("B17:R" & Dong)                          'Cot cuoi cung tai Sheet Input_TB
        Dong = UBound(Nguon)
    End With
Nhấp chuột vào đây để mở rộng...
Không được bạn ơi
 
Upvote 0
vanaccex đã viết:
Bạn xem thử xem
Nhấp chuột vào đây để mở rộng...
Thanks bạn nhiều!
Mình muốn lấy cái tiêu đề của công việc nhân viên đó luôn được không bạn
Bước 2 tách theo từng nhân viên ra từng Sheet riêng mà cái này em ko biết làm nữa mong anh chị giúp với ạ
 

File đính kèm

  • Tieu de.PNG
    Tieu de.PNG
    15.6 KB · Đọc: 25
Upvote 0
Kính mong các anh giúp em với ạ
Em có thêm đoạn Code phân chia Sheet được rồi, tuy nhiên chạy không đúng kết quả như mong muốn ạ
Mã: 
Option Explicit
'Option Private Module
Sub Run_BB_2B()

    Dim i, k, ar, ketqua
    Dim Nguon, Dong
    Dim LastRow
    Dim ws1 As Worksheet
    Dim wsNew As Worksheet
    Dim g As Range
    Set ws1 = Sheets("GV-KTHT")

    With ws1
        Dong = .Range("B" & .Rows.Count).End(xlUp).Row
        Nguon = .Range("B17:R" & Dong)                          'Cot cuoi cung tai Sheet Input_TB
        Dong = UBound(Nguon)
    End With

    'Tim Du lieu
    For Each g In Sheets("TH KI").Range("C8:C20")
        'Tieu chí trích loc
'        Nguon(i, 11).Value = _
            "=""="" & " & Chr(34) & g.Value & Chr(34) 'c.Value & Chr(34)
        'Tao sheet moi
'        End

        'Láy du lieu vào các sheet
    ReDim ketqua(1 To Dong, 1 To 15)

    For i = 1 To Dong
      If Nguon(i, 11) = g.Value Then       'Ktra lay nhung vat tu DVSD
            k = k + 1
            ketqua(k, 1) = k
            ketqua(k, 2) = Nguon(i, 1)
            ketqua(k, 4) = 1
            ketqua(k, 6) = Nguon(i, 14)          'Ten VTTB
            ketqua(k, 7) = Nguon(i, 4)          'Ma VT
            ketqua(k, 8) = Nguon(i, 6)          'So luong nghiem thu
            ketqua(k, 9) = Nguon(i, 4)          'Don gia

      End If
    Next i
        Set wsNew = Sheets.Add
        wsNew.Move After:=Worksheets(Worksheets.Count)

        'dat ten cho sheet moi
        wsNew.Name = "Giaoviec" & g.Value
    With wsNew
       LastRow = wsNew.Cells(Rows.Count, "P").End(xlUp).Row

       If LastRow > 18 Then
          .Rows("18:" & LastRow - 1).Delete Shift:=xlShiftUp
       Else
          .Range("A18:K" & LastRow).ClearContents
       End If

      .Range("A18:A" & 18 + k - 1).EntireRow.Insert
        If k Then
          .Range("A18").Resize(k, 15).Value = ketqua
    
          .Range("C18:F" & 18 + k - 1).WrapText = 1
          .Range("C18:F" & 18 + k - 1).HorizontalAlignment = xlJustify
          .Range("A18:M" & 18 + k - 1).Font.Bold = False
          .Range("A18").Resize(k, 15).Borders.LineStyle = 1
          .Range("H18:J" & 18 + k + 1).NumberFormat = "#,##0.00"
          .Range("J" & 18 + k + 1).Formula = "=SUBTOTAL(9,J18:J" & 18 + k & ")"
          'Can chinh
'          .Rows("18:" & LastRow - 1 & "").RowHeight = 35
          .Rows("" & LastRow & ":" & LastRow + 4 & "").RowHeight = 23
          .PageSetup.PrintArea = "$A$1:$O" & LastRow + 7 & ""
        End If
    End With

    Next


End Sub
 

File đính kèm

Upvote 0
Các anh chị ơi xem giúp em với. Em mò tới mò lui không biết sao các Sheet sau khi tách không lấy được dữ liệu ra trang trắng không ạ
 
Upvote 0
Các anh chị ơi xem giúp em đoạn Code với ạ, nó ra kết quả nhưng không ở tại dòng thứ A18 của từng Sheet mà nó chạy thứ tự lung tung hết cả, em không rõ sắp xếp code thế nào chạy cho đúng ý nữa
 
Upvote 0
quyenpv đã viết:
Các anh chị ơi xem giúp em với. Em mò tới mò lui không biết sao các Sheet sau khi tách không lấy được dữ liệu ra trang trắng không ạ
Nhấp chuột vào đây để mở rộng...
Em đưa File với 2 sheet có kết quả cần tách để anh xem có cách nào khác không.
 
Upvote 0
(@$%@(@$%@(@$%@
 
Upvote 0
quyenpv đã viết:
(@$%@(@$%@(@$%@
Nhấp chuột vào đây để mở rộng...
Em bé đùng khóc, diễn đàn ngập lụt rồi
Mã: 
Option Explicit

Sub xyz()
  Dim aTHKI(), aGV(), Res(), Dic As Object
  Dim Rng As Range, RngFormat As Range
  Dim sRow&, i&, r&, k&, ik&, Mail$, tmp
  Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For i = Sheets.Count To 1 Step -1
    If Left(Sheets(i).Name, 9) = "Giaoviec_" Then Sheets(i).Delete
  Next i
  With Sheets("Mau Giao viec")
    Set Rng = .Range("A20:O25")
    Set RngFormat = .Range("A18:O18")
  End With
  With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
  End With
  With Sheets("TH KI")
    aTHKI = .Range("C8:M" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
  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 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)
        k = 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 Then
              k = k + 1:                bTd1 = False
              Res(k, 1) = aGV(fR1, 1):  Res(k, 2) = aGV(fR1, 2)
            End If
            If bTd2 = True 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
        Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
        With 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)
        End With
      End If
    End If
  Next i
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
 

File đính kèm

Upvote 0
befalnt đã viết:
Cái này dùng Vlookup và Sumprodut là được mà
Bài đã được tự động gộp:


If IsNumeric(tmp) Then tR2 = i Else tR1 = i
Đoạn này cần chú ý anh nhé. ẩu tả quá
Nhấp chuột vào đây để mở rộng...
Trước đó còn
If tmp <> Empty And tmp <> "+" Then
If IsNumeric(tmp) Then tR2 = i Else tR1 = i
Khả năng sụp hố thấp
 
Upvote 0
HieuCD đã viết:
Em bé đùng khóc, diễn đàn ngập lụt rồi
Mã: 
Option Explicit

Sub xyz()
  Dim aTHKI(), aGV(), Res(), Dic As Object
  Dim Rng As Range, RngFormat As Range
  Dim sRow&, i&, r&, k&, ik&, Mail$, tmp
  Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For i = Sheets.Count To 1 Step -1
    If Left(Sheets(i).Name, 9) = "Giaoviec_" Then Sheets(i).Delete
  Next i
  With Sheets("Mau Giao viec")
    Set Rng = .Range("A20:O25")
    Set RngFormat = .Range("A18:O18")
  End With
  With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
  End With
  With Sheets("TH KI")
    aTHKI = .Range("C8:M" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
  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 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)
        k = 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 Then
              k = k + 1:                bTd1 = False
              Res(k, 1) = aGV(fR1, 1):  Res(k, 2) = aGV(fR1, 2)
            End If
            If bTd2 = True 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
        Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
        With 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)
        End With
      End If
    End If
  Next i
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Dạ em cám ơn anh nhiều ạ
Bài đã được tự động gộp:

HieuCD đã viết:
Trước đó còn
If tmp <> Empty And tmp <> "+" Then
If IsNumeric(tmp) Then tR2 = i Else tR1 = i
Khả năng sụp hố thấp
Nhấp chuột vào đây để mở rộng...
Em gà lắm nền các anh nói kỹ giúp em với, trình độ code và debug còn kém lắm ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Khi chạy Code em thấy lặp lại 1 người có 2 Sheet phiếu giao việc. Ví dụ : tungdht3
Nhờ các anh kiểm tra giúp em với ạ
 

File đính kèm

Upvote 0
befaint đã viết:
Nick đó đang mạo danh anh ơi.

View attachment 234723
Nhấp chuột vào đây để mở rộng...
Vậy hả, mình không để ý
Bài đã được tự động gộp:

quyenpv đã viết:
Khi chạy Code em thấy lặp lại 1 người có 2 Sheet phiếu giao việc. Ví dụ : tungdht3
Nhờ các anh kiểm tra giúp em với ạ
Nhấp chuột vào đây để mở rộng...
Có 2 Tùng: tungdht3 và tungght3
Bài đã được tự động gộp:

quyenpv đã viết:
Dạ em cám ơn anh nhiều ạ
Bài đã được tự động gộp:


Em gà lắm nền các anh nói kỹ giúp em với, trình độ code và debug còn kém lắm ạ
Nhấp chuột vào đây để mở rộng...
Dữ liệu đề mục lung tung nên khó xét điều kiện lấy đề mục, tiêu chuẩn nào cũng bị sót
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Vậy hả, mình không để ý
Bài đã được tự động gộp:


Có 2 Tùng: tungdht3 và tungght3
Bài đã được tự động gộp:


Dữ liệu đề mục lung tung nên khó xét điều kiện lấy đề mục, tiêu chuẩn nào cũng bị sót
Nhấp chuột vào đây để mở rộng...
Dạ em cám ơn anh. Dữ liệu đề mục không cố định theo các mảng công việc giao nên cũng khó anh ạ. Như thế là tốt lắm rồi anh
 
Upvote 0
Hix nó bị lỗi này anh ạ, giờ mở lại chạy không rõ sao nữa
Runtime Error: 9

1585992082629.png
 

File đính kèm

Upvote 0
quyenpv đã viết:
Hix nó bị lỗi này anh ạ, giờ mở lại chạy không rõ sao nữa
Runtime Error: 9

View attachment 234733
Nhấp chuột vào đây để mở rộng...
Do file của bạn không có đề mục, thêm điều kiện
Mã: 
Option Explicit

Sub xyz()
  Dim aTHKI(), aGV(), Res(), Dic As Object
  Dim Rng As Range, RngFormat As Range
  Dim sRow&, i&, r&, k&, ik&, Mail$, tmp
  Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For i = Sheets.Count To 1 Step -1
    If Left(Sheets(i).Name, 9) = "Giaoviec_" Then Sheets(i).Delete
  Next i
  With Sheets("Mau Giao viec")
    Set Rng = .Range("A20:O25")
    Set RngFormat = .Range("A18:O18")
  End With
  With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
  End With
  With Sheets("TH KI")
    aTHKI = .Range("C8:M" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
  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 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)
        k = 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)
            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
        Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
        With 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)
        End With
      End If
    End If
  Next i
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
HieuCD đã viết:
Do file của bạn không có đề mục, thêm điều kiện
Mã: 
Option Explicit

Sub xyz()
  Dim aTHKI(), aGV(), Res(), Dic As Object
  Dim Rng As Range, RngFormat As Range
  Dim sRow&, i&, r&, k&, ik&, Mail$, tmp
  Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For i = Sheets.Count To 1 Step -1
    If Left(Sheets(i).Name, 9) = "Giaoviec_" Then Sheets(i).Delete
  Next i
  With Sheets("Mau Giao viec")
    Set Rng = .Range("A20:O25")
    Set RngFormat = .Range("A18:O18")
  End With
  With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
  End With
  With Sheets("TH KI")
    aTHKI = .Range("C8:M" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
  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 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)
        k = 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)
            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
        Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
        With 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)
        End With
      End If
    End If
  Next i
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Dear anh HieuCD
Em nhờ anh chỉnh sửa giúp em một chút là các Sheet Giao việc này tách sang Workbook mới với ạ
Em cám ơn anh nhiều
 
Upvote 0
HieuCD đã viết:
Bạn tìm code tách sheet thành file trên diễn đàn, và tự chỉnh lại
Nhấp chuột vào đây để mở rộng...
Em thêm đoạn code
Mã: 
    Dim wb As Workbook
    Set wb = Workbooks.Add
    Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
Nó chạy ra nhiều workbook chứ không phải tạo 1 workbook có nhiều Sheet phiếu giao việc anh
 
Upvote 0
quyenpv đã viết:
Em thêm đoạn code
Mã: 
    Dim wb As Workbook
    Set wb = Workbooks.Add
    Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
Nó chạy ra nhiều workbook chứ không phải tạo 1 workbook có nhiều Sheet phiếu giao việc anh
Nhấp chuột vào đây để mở rộng...
quyenpv đã viết:
Dear anh HieuCD
Em nhờ anh chỉnh sửa giúp em một chút là các Sheet Giao việc này tách sang Workbook mới với ạ
Em cám ơn anh nhiều
Nhấp chuột vào đây để mở rộng...
Mình chỉnh lại 1 chút code của anh @HieuCD, bạn tham khảo thử nhé:
Rich (BB code): 
Option Explicit

Sub xyz()
  Dim aTHKI(), aGV(), Res(), dic As Object
  Dim Rng As Range, RngFormat As Range
  Dim sRow&, i&, r&, k&, ik&, Mail$, tmp
  Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For i = Sheets.Count To 1 Step -1
    If Left(Sheets(i).Name, 9) = "Giaoviec_" Then Sheets(i).Delete
  Next i
  With Sheets("Mau Giao viec")
    Set Rng = .Range("A20:O25")
    Set RngFormat = .Range("A18:O18")
  End With
  With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
  End With
  With Sheets("TH KI")
    aTHKI = .Range("C8:M" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
  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 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)
        k = 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)
            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
        Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
        With 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)
          
          ActiveSheet.Copy
          Application.ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
          Application.ActiveWorkbook.Close False
          ActiveSheet.Delete
          
        End With
      End If
    End If
  Next i
 
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Các dòng màu đỏ là mình mới thêm:
PHP: 
          ActiveSheet.Copy

          Application.ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
          Application.ActiveWorkbook.Close False
          ActiveSheet.Delete
 

File đính kèm

Upvote 0
quick87 đã viết:
Mình chỉnh lại 1 chút code của anh @HieuCD, bạn tham khảo thử nhé:
Rich (BB code): 
Option Explicit

Sub xyz()
  Dim aTHKI(), aGV(), Res(), dic As Object
  Dim Rng As Range, RngFormat As Range
  Dim sRow&, i&, r&, k&, ik&, Mail$, tmp
  Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For i = Sheets.Count To 1 Step -1
    If Left(Sheets(i).Name, 9) = "Giaoviec_" Then Sheets(i).Delete
  Next i
  With Sheets("Mau Giao viec")
    Set Rng = .Range("A20:O25")
    Set RngFormat = .Range("A18:O18")
  End With
  With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
  End With
  With Sheets("TH KI")
    aTHKI = .Range("C8:M" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
  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 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)
        k = 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)
            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
        Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
        With 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)
         
          ActiveSheet.Copy
          Application.ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
          Application.ActiveWorkbook.Close False
          ActiveSheet.Delete
         
        End With
      End If
    End If
  Next i

  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Các dòng màu đỏ là mình mới thêm:
PHP: 
          ActiveSheet.Copy

          Application.ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
          Application.ActiveWorkbook.Close False
          ActiveSheet.Delete
Nhấp chuột vào đây để mở rộng...
Cám ơn anh. Ví dụ muốn tạo 1 workbook chứa nhiều sheet đó chỉnh sao anh
 
Upvote 0
quyenpv đã viết:
Cám ơn anh. Ví dụ muốn tạo 1 workbook chứa nhiều sheet đó chỉnh sao anh
Nhấp chuột vào đây để mở rộng...
Mình có thêm đoạn code tách sheets ra files theo yêu cầu của bạn:
Mã: 
Option Explicit

Sub xyz()
  Dim aTHKI(), aGV(), Res(), dic As Object
  Dim Rng As Range, RngFormat As Range
  Dim sRow&, i&, r&, k&, ik&, Mail$, tmp
  Dim stt&, tR1&, tR2&, fR1&, fR2&, bTd1 As Boolean, bTd2 As Boolean
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  For i = Sheets.Count To 1 Step -1
    If Left(Sheets(i).Name, 9) = "Giaoviec_" Then Sheets(i).Delete
  Next i
  With Sheets("Mau Giao viec")
    Set Rng = .Range("A20:O25")
    Set RngFormat = .Range("A18:O18")
  End With
  With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
  End With
  With Sheets("TH KI")
    aTHKI = .Range("C8:M" & .Range("D" & .Rows.Count).End(xlUp).Row).Value
  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 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)
        k = 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)
            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
        Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
        With 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)
          
          'ActiveSheet.Copy
          'Application.ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
          'Application.ActiveWorkbook.Close False
          'ActiveSheet.Delete
          
        End With
      End If
    End If
  Next i
  TachSheets
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

Sub TachSheets()
    Dim wk As Worksheet
    Dim wb As Workbook
    Dim str_name As String
    Dim arr() As String
    For Each wk In Worksheets
        If Left(Trim(wk.Name), 9) = "Giaoviec_" Then
            str_name = str_name & "," & wk.Name
        End If
    Next wk
    str_name = Right(str_name, Len(str_name) - 1)
    arr = Split(str_name, ",")
    Set wb = Workbooks.Add
    Windows("Help_Giao viec 148658#31.xlsm").Activate
    Sheets(arr).Move Before:=Workbooks(wb.Name).Sheets(1)
    ActiveWorkbook.SaveAs FileName:=ThisWorkbook.Path & "\" & "Giaoviec_Tonghop" & ".xlsx"
    ActiveWorkbook.Close False
End Sub

Bạn nhận và chạy thử lại file đính kèm xem đúng ý bạn chưa nhé.
 

File đính kèm

Upvote 0
quyenpv đã viết:
Em thêm đoạn code
Mã: 
    Dim wb As Workbook
    Set wb = Workbooks.Add
    Sheets("Mau Giao viec").Copy After:=Sheets(Sheets.Count)
Nó chạy ra nhiều workbook chứ không phải tạo 1 workbook có nhiều Sheet phiếu giao việc anh
Nhấp chuột vào đây để mở rộng...
Copy 1 workbook trước, tạo các sheet sau
Mã: 
Option Explicit

Sub xyz()
  Dim aTHKI(), aGV(), Res(), Dic As Object, wB As Workbook
  Dim Rng As Range, RngFormat As Range
  Dim sRow&, i&, r&, k&, ik&, 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
  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 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)
        k = 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)
            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)
        End With
      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
 
Upvote 0
Dear HieuCD
Em nhờ anh giúp em với ạ, anh có thể giúp em Code gửi email đến các cá nhân có công việc tồn quá hạn triển khai dựa vào cột O (Thời gian H.Thành)
1. Body email có list công việc
2. Attach file đính kèm
Em cám ơn anh

VD như file đính kèm ạ
1588825674950.png
 
Upvote 0
quyenpv đã viết:
Dear HieuCD
Em nhờ anh giúp em với ạ, anh có thể giúp em Code gửi email đến các cá nhân có công việc tồn quá hạn triển khai dựa vào cột O (Thời gian H.Thành)
1. Body email có list công việc
2. Attach file đính kèm
Em cám ơn anh

VD như file đính kèm ạ
View attachment 236959
Nhấp chuột vào đây để mở rộng...
Mình không biết các lệnh gởi mail, bạn nên mở topic mới
 
Upvote 0
HieuCD đã viết:
Copy 1 workbook trước, tạo các sheet sau
Mã: 
Option Explicit

Sub xyz()
  Dim aTHKI(), aGV(), Res(), Dic As Object, wB As Workbook
  Dim Rng As Range, RngFormat As Range
  Dim sRow&, i&, r&, k&, ik&, 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
  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 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)
        k = 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)
            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)
        End With
      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
Nhấp chuột vào đây để mở rộng...
Dear anh @HieuCD
Em nhờ anh chỉnh giúp em đoạn Code đầu mục công việc của từng người theo thứ tự A, B, C và được in đậm thay vì lấy từ Sheet qua ạ
Em cám ơn
Mã: 
If bTd1 = True And fR1 > 0 Then

              k = k + 1:                bTd1 = False

              Res(k, 1) = aGV(fR1, 1):  Res(k, 2) = aGV(fR1, 2)

            End If

1612837998021.png
 
Upvote 0
quyenpv đã viết:
Dear anh @HieuCD
Em nhờ anh chỉnh giúp em đoạn Code đầu mục công việc của từng người theo thứ tự A, B, C và được in đậm thay vì lấy từ Sheet qua ạ
Em cám ơn
Mã: 
If bTd1 = True And fR1 > 0 Then

              k = k + 1:                bTd1 = False

              Res(k, 1) = aGV(fR1, 1):  Res(k, 2) = aGV(fR1, 2)

            End If

View attachment 254086
Nhấp chuột vào đây để mở rộng...
Chỉnh 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
  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
  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 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
  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
 
Upvote 0
HieuCD đã viết:
Chỉnh 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
  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
  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 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
  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
Nhấp chuột vào đây để mở rộng...
Em cám ơn anh rát nhiều
 
Upvote 0
Dear anh @HieuCD
Bác thương em bác thương thêm lần nữa với ạ. Do dữ liệu được cập nhật thường xuyên, các công việc được giao các tháng tiếp theo liền kề bên dưới, để cho mỗi lần sử dụng không phải vào sửa code đoạn này
Mã: 
With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
End With
Anh giúp em thêm cho phép chọn khoảng thời gian giao việc từ ngày xx/xx/xxxx đến ngày yy/yy/yyyy. Vid dụ trên Sheet em đang để từ cột M3 và cột O3 ạ
Bài đã được tự động gộp:

1613015554118.png

Chúc anh và gia đình chuẩn bị bước sang năm mới mạnh khỏe, vạn sự như ý, thành công viên mãn. Chúc diễn đàn ngày càng phát triển, mãi là động lực, cầu nối cho anh em học hỏi, trao đổi
 

File đính kèm

Upvote 0
quyenpv đã viết:
Dear anh @HieuCD
Bác thương em bác thương thêm lần nữa với ạ. Do dữ liệu được cập nhật thường xuyên, các công việc được giao các tháng tiếp theo liền kề bên dưới, để cho mỗi lần sử dụng không phải vào sửa code đoạn này
Mã: 
With Sheets("GV-KTHT")
    aGV = .Range("A17:P" & .Range("C" & .Rows.Count).End(xlUp).Row).Value
End With
Anh giúp em thêm cho phép chọn khoảng thời gian giao việc từ ngày xx/xx/xxxx đến ngày yy/yy/yyyy. Vid dụ trên Sheet em đang để từ cột M3 và cột O3 ạ
Bài đã được tự động gộp:

View attachment 254144
Nhấp chuột vào đây để mở rộng...
Còn gì nữa không?
 
Upvote 0
Hết rồi anh ạ. Nhờ anh giúp em với ạ
 
Upvote 0
quyenpv đã viết:
Hết rồi anh ạ. Nhờ anh giúp em với ạ
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
Em cám ơn anh rất nhiều, Code chuẩn rồi ạ
 
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

S
Power BI. Một quá trình đòi hỏi sự kiên nhẫn.
Trả lời
3
Đọc
138
tranhungdao12a3
T
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD
    • Thích
Trả lời
15
Đọc
939
Hoàng Tuấn 868
H
SA_DQ
  • Question Question
Bài tập VBA cho những người rỗi. . . đủ thứ!
    • Cười
    • Yêu thích
Trả lời
21
Đọc
682
Phuocam
Phuocam
H
Giúp mình ghép nhiều file thành một file. (1 người xem)
Trả lời
9
Đọc
306
Hoàng Tuấn 868
H
H
  • Question Question
Dò tìm giá trị từ bảng khác theo cột
Trả lời
5
Đọc
92
ptm0412
ptm0412
L
Cách bật/tắt đèn led thứ 3 trên bàn phím cơ
Trả lời
1
Đọc
52
HUONGHCKT
H
C
Không thể group cột trong excel
Trả lời
10
Đọc
12K
ptm0412
ptm0412
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn
Trả lời
14
Đọc
953
Hoàng Tuấn 868
H
H
Xin giúp đỡ về phổ cập (1 người xem)
Trả lời
5
Đọc
983
tranvanky8111967
T
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
420
Đọc
51K
maingoctu89
M
P
Xin giúp sửa code VBA tổng hợp sản lượng theo format file FCS đổ từ hệ thống ERP.
Trả lời
14
Đọc
294
DeTong
D
L
Nhờ anh chị giúp đỡ công thức hàm len
Trả lời
44
Đọc
737
khuong182018
khuong182018
hongphuong1997
Cách tô màu một dòng theo chiều cao tùy ý
Trả lời
5
Đọc
192
hongphuong1997
hongphuong1997
D
nhờ anh chị giải thích hàm hstack
Trả lời
2
Đọc
138
dungpham01
D
L
Nhờ anh chị giúp giúp đỡ hàm ạ
    • Chấp nhận
Trả lời
12
Đọc
364
Phan Thế Hiệp
Phan Thế Hiệp
vuthaiha90
Lọc dữ liệu không trùng và trả kết quả về 1 dòng
Trả lời
6
Đọc
191
Duy Tùng 9x
Duy Tùng 9x
B
Copy textbox giữa 2 userform
Trả lời
6
Đọc
232
Bảo_Anh_
B
L
  • Question Question
Khi chọn sheet 2, thì mặc định chọn ô A5 (1 người xem)
Trả lời
1
Đọc
104
vu_tuan_manh_linh
vu_tuan_manh_linh
ongke0711
  • Question Question
Tra cứu thông tin mã số thuế (cập nhật lại code cũ)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
11
Đọc
812
ongke0711
ongke0711
H
Giúp đỡ Hàm tính ngày hết khấu hao, phân bổ?
Trả lời
2
Đọc
126
hitlecp
H
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