Code tập hợp KPI theo tháng

Phương Phương mito · 18/8/20

Kính gửi Anh chị và các bạn,
Em đang làm việc tổng hợp kết quả đánh giá nhân viên theo như File và Format như kèm theo. kết quả của mỗi người là kết quả do "Cán bộ có thẩm quyền phê duyệt đánh giá" và lấy theo kết quả này và lấy tại Cột G, T, U tại mỗi Sheet của mỗi tháng. Với điều kiện lọc là Mã ID của nhân viên. Giờ có Code gì để tự động lọc từ các Sheet được không ạ. (Các sheet T1,T2, T3....có thể tùy ý thêm bớt ạ và đảm bảo đúng mẫu).

snow25 · 18/8/20

khanhly94 đã viết:
Kính gửi Anh chị và các bạn,
Em đang làm việc tổng hợp kết quả đánh giá nhân viên theo như File và Format như kèm theo. kết quả của mỗi người là kết quả do "Cán bộ có thẩm quyền phê duyệt đánh giá" và lấy theo kết quả này và lấy tại Cột G, T, U tại mỗi Sheet của mỗi tháng. Với điều kiện lọc là Mã ID của nhân viên. Giờ có Code gì để tự động lọc từ các Sheet được không ạ. (Các sheet T1,T2, T3....có thể tùy ý thêm bớt ạ và đảm bảo đúng mẫu).

Bạn đổi tên sheets thanh Tong hop rồi chạy code thử nhé.

Mã:

Sub tonghop()
    Dim arr, i As Long, kq, dic As Object, dk As String, a As Long, sh As Worksheet, b As Long, d As Long, c As Long, e As Long
    Dim lr As Long
    Set dic = CreateObject("scripting.dictionary")
    ReDim kq(1 To 1000, 1 To 41)
    With Sheets("tong hop")
         For i = 6 To 17
             dk = "CM" & .Cells(2, i).Value
             dic.Item(dk) = i
         Next i
         For i = 18 To 29
             dk = "TL" & .Cells(2, i).Value
             dic.Item(dk) = i
         Next i
         For i = 30 To 41
             dk = "XL" & .Cells(2, i).Value
             dic.Item(dk) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Tong hop" Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row + 2
           If lr > 10 Then
              arr = sh.Range("A9:U" & lr).Value
              dk = "CM" & sh.Name
              b = dic.Item(dk)
                If b Then
                   dk = "TL" & sh.Name
                   c = dic.Item(dk)
                   If c Then
                      dk = "XL" & sh.Name
                      d = dic.Item(dk)
                      If d Then
                         For i = 1 To UBound(arr)
                             If Len(arr(i, 2)) > 0 Then
                                dk = arr(i, 2)
                                If Not dic.exists(dk) Then
                                   a = a + 1
                                   dic.Add dk, a
                                   kq(a, 1) = a
                                   kq(a, 2) = dk
                                   kq(a, 3) = arr(i, 3)
                                   kq(a, 4) = arr(i, 4)
                                   kq(a, 5) = arr(i, 5)
                                End If
                                   e = dic.Item(dk)
                                   kq(e, b) = arr(i + 2, 7)
                                   kq(e, c) = arr(i + 2, 20)
                                   kq(e, d) = arr(i + 2, 21)
                            End If
                       Next i
                    End If
                End If
           End If
      End If
   End If
 Next
    With Sheets("tong hop")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AO" & lr).ClearContents
         If a Then .Range("A3:AO3").Resize(a).Value = kq
    End With
End Sub

Phương Phương mito · 18/8/20

snow25 đã viết:

Bạn đổi tên sheets thanh Tong hop rồi chạy code thử nhé.

Mã:

Sub tonghop()
    Dim arr, i As Long, kq, dic As Object, dk As String, a As Long, sh As Worksheet, b As Long, d As Long, c As Long, e As Long
    Dim lr As Long
    Set dic = CreateObject("scripting.dictionary")
    ReDim kq(1 To 1000, 1 To 41)
    With Sheets("tong hop")
         For i = 6 To 17
             dk = "CM" & .Cells(2, i).Value
             dic.Item(dk) = i
         Next i
         For i = 18 To 29
             dk = "TL" & .Cells(2, i).Value
             dic.Item(dk) = i
         Next i
         For i = 30 To 41
             dk = "XL" & .Cells(2, i).Value
             dic.Item(dk) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Tong hop" Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row + 2
           If lr > 10 Then
              arr = sh.Range("A9:U" & lr).Value
              dk = "CM" & sh.Name
              b = dic.Item(dk)
                If b Then
                   dk = "TL" & sh.Name
                   c = dic.Item(dk)
                   If c Then
                      dk = "XL" & sh.Name
                      d = dic.Item(dk)
                      If d Then
                         For i = 1 To UBound(arr)
                             If Len(arr(i, 2)) > 0 Then
                                dk = arr(i, 2)
                                If Not dic.exists(dk) Then
                                   a = a + 1
                                   dic.Add dk, a
                                   kq(a, 1) = a
                                   kq(a, 2) = dk
                                   kq(a, 3) = arr(i, 3)
                                   kq(a, 4) = arr(i, 4)
                                   kq(a, 5) = arr(i, 5)
                                End If
                                   e = dic.Item(dk)
                                   kq(e, b) = arr(i + 2, 7)
                                   kq(e, c) = arr(i + 2, 20)
                                   kq(e, d) = arr(i + 2, 21)
                            End If
                       Next i
                    End If
                End If
           End If
      End If
   End If
Next
    With Sheets("tong hop")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AO" & lr).ClearContents
         If a Then .Range("A3:AO3").Resize(a).Value = kq
    End With
End Sub

Hay quá anh ạ. Code chạy đúng rồi ạ. Em cảm ơn anh nhiều !

Bài đã được tự động gộp: 18/8/20

snow25 đã viết:

Bạn đổi tên sheets thanh Tong hop rồi chạy code thử nhé.

Mã:

Sub tonghop()
    Dim arr, i As Long, kq, dic As Object, dk As String, a As Long, sh As Worksheet, b As Long, d As Long, c As Long, e As Long
    Dim lr As Long
    Set dic = CreateObject("scripting.dictionary")
    ReDim kq(1 To 1000, 1 To 41)
    With Sheets("tong hop")
         For i = 6 To 17
             dk = "CM" & .Cells(2, i).Value
             dic.Item(dk) = i
         Next i
         For i = 18 To 29
             dk = "TL" & .Cells(2, i).Value
             dic.Item(dk) = i
         Next i
         For i = 30 To 41
             dk = "XL" & .Cells(2, i).Value
             dic.Item(dk) = i
         Next i
    End With
    For Each sh In ThisWorkbook.Worksheets
        If sh.Name <> "Tong hop" Then
           lr = sh.Range("B" & Rows.Count).End(xlUp).Row + 2
           If lr > 10 Then
              arr = sh.Range("A9:U" & lr).Value
              dk = "CM" & sh.Name
              b = dic.Item(dk)
                If b Then
                   dk = "TL" & sh.Name
                   c = dic.Item(dk)
                   If c Then
                      dk = "XL" & sh.Name
                      d = dic.Item(dk)
                      If d Then
                         For i = 1 To UBound(arr)
                             If Len(arr(i, 2)) > 0 Then
                                dk = arr(i, 2)
                                If Not dic.exists(dk) Then
                                   a = a + 1
                                   dic.Add dk, a
                                   kq(a, 1) = a
                                   kq(a, 2) = dk
                                   kq(a, 3) = arr(i, 3)
                                   kq(a, 4) = arr(i, 4)
                                   kq(a, 5) = arr(i, 5)
                                End If
                                   e = dic.Item(dk)
                                   kq(e, b) = arr(i + 2, 7)
                                   kq(e, c) = arr(i + 2, 20)
                                   kq(e, d) = arr(i + 2, 21)
                            End If
                       Next i
                    End If
                End If
           End If
      End If
   End If
Next
    With Sheets("tong hop")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 2 Then .Range("A3:AO" & lr).ClearContents
         If a Then .Range("A3:AO3").Resize(a).Value = kq
    End With
End Sub

A có thể cho em biết, ý tưởng anh giải bài này bằng Code của anh như thế nào không ạ.

HieuCD · 18/8/20

khanhly94 đã viết:
Kính gửi Anh chị và các bạn,
Em đang làm việc tổng hợp kết quả đánh giá nhân viên theo như File và Format như kèm theo. kết quả của mỗi người là kết quả do "Cán bộ có thẩm quyền phê duyệt đánh giá" và lấy theo kết quả này và lấy tại Cột G, T, U tại mỗi Sheet của mỗi tháng. Với điều kiện lọc là Mã ID của nhân viên. Giờ có Code gì để tự động lọc từ các Sheet được không ạ. (Các sheet T1,T2, T3....có thể tùy ý thêm bớt ạ và đảm bảo đúng mẫu).

Thử code

Mã:

Sub ABC()
  Dim sArr(), aCol, Res(), Dic As Object, sh As Worksheet
  Dim eRow&, sRow&, i&, k&, ik&, jSh&, j&
  Dim iKey
  Const shName = ",,,,T1,,T2,,T3,,T4,,T5,,T6,,T7,,T8,,T9,,T10,T11,T12,"
  aCol = Array(6, 19, 20)
 
  Set Dic = CreateObject("scripting.dictionary")
  ReDim Res(1 To 1000, 1 To 41)
  For Each sh In ThisWorkbook.Worksheets
    jSh = InStr(1, shName, "," & sh.Name & ",") \ 4
    If jSh > 0 Then
      eRow = sh.Range("B" & Rows.Count).End(xlUp).Row + 2
      If eRow > 9 Then
        sArr = sh.Range("B9:U" & eRow).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          iKey = sArr(i, 1)
          If iKey <> Empty Then
            If Dic.exists(iKey) = False Then
              k = k + 1
              Dic.Add iKey, k
              Res(k, 1) = k
              For j = 1 To 4
                Res(k, j + 1) = sArr(i, j)
              Next j
            End If
            ik = Dic.Item(iKey)
            For n = 0 To 2
              Res(ik, 5 + n * 12 + jSh) = sArr(i + 2, aCol(n))
            Next n
          End If
        Next i
      End If
    End If
  Next
  With Sheet1
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 2 Then .Range("A3:AO" & eRow).ClearContents
    If k Then .Range("A3:AO3").Resize(k).Value = Res
  End With
End Sub

Phương Phương mito · 18/8/20

HieuCD đã viết:

Thử code

Mã:

Sub ABC()
  Dim sArr(), aCol, Res(), Dic As Object, sh As Worksheet
  Dim eRow&, sRow&, i&, k&, ik&, jSh&, j&
  Dim iKey
  Const shName = ",,,,T1,,T2,,T3,,T4,,T5,,T6,,T7,,T8,,T9,,T10,T11,T12,"
  aCol = Array(6, 19, 20)

  Set Dic = CreateObject("scripting.dictionary")
  ReDim Res(1 To 1000, 1 To 41)
  For Each sh In ThisWorkbook.Worksheets
    jSh = InStr(1, shName, "," & sh.Name & ",") \ 4
    If jSh > 0 Then
      eRow = sh.Range("B" & Rows.Count).End(xlUp).Row + 2
      If eRow > 9 Then
        sArr = sh.Range("B9:U" & eRow).Value
        sRow = UBound(sArr)
        For i = 1 To sRow
          iKey = sArr(i, 1)
          If iKey <> Empty Then
            If Dic.exists(iKey) = False Then
              k = k + 1
              Dic.Add iKey, k
              Res(k, 1) = k
              For j = 1 To 4
                Res(k, j + 1) = sArr(i, j)
              Next j
            End If
            ik = Dic.Item(iKey)
            For n = 0 To 2
              Res(ik, 5 + n * 12 + jSh) = sArr(i + 2, aCol(n))
            Next n
          End If
        Next i
      End If
    End If
  Next
  With Sheet1
    eRow = .Range("A" & Rows.Count).End(xlUp).Row
    If eRow > 2 Then .Range("A3:AO" & eRow).ClearContents
    If k Then .Range("A3:AO3").Resize(k).Value = Res
  End With
End Sub

Code hay quá ạ. Em cảm ơn anh đã giúp đỡ ạ !

Code tập hợp KPI theo tháng

Phương Phương mito

Thành viên thường trực

File đính kèm

snow25

Thành viên gạo cội

Phương Phương mito

Thành viên thường trực

HieuCD

Chuyên gia GPE

Phương Phương mito

Thành viên thường trự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