Lọc dữ liệu các sheet và sum kết quả vào 1 sheet mới !!!! (1 người xem)

[firstsight8719]

Tình hình là e hơi gà về excell, mong các cao thủ chỉ dẫn giùm cho.
Em đang làm bảng lương, muốn sum lại tiền lương của nhân viên trong 12 tháng,( có người làm không đủ 12 tháng ),1 tháng là 1 sheet, e chỉ đưa lên 3 tháng thôi
Mỗi nhân viên có 1 mã số thẻ riêng biệt (cột B)

Em muốn sum lại tiền lương của nhân viên ở cột " tổng lương" và " thực lãnh " ( cột AP và AQ) trong 3 tháng và cho kết quả ở 1 sheet mới, giữ nguyên cột A Đến J và từ AP đến BA ở sheet mới
các cột còn lại có thể bỏ

 

[firstsight8719]

Lọc dữ liệu các sheet và sum kết quả vào 1 sheet mới !!!!

 

[SA_DQ]

Vì bạn chưa đưa ra trang tổng hợp, nên mình tự vẻ ra vậy thôi

​

 

[firstsight8719]

Sorry bạn HYen17 nghe, do mình sơ suất nên ko làm trang tổng hợp yêu cầu
Ý mình muốn tìm tổng lương của nhân viên đó trong 12 tháng
Mình post lại file có trang tổng hợp, bạn xem lại giùm mình với nha
thanks bạn nhìu !!!
http://www.mediafire.com/?a8io4q263f188h8

 

[SA_DQ]

Bạn lấy toàn bộ con macro này chép đè lên con cũ & chạy mệt nghỉ

Option Explicit
Dim Sh As Worksheet:                            Const SS As Integer = 310
Sub Tong_Hop()
 Dim Cls As Range, Rng As Range, sRng As Range

 Sheets("THop").Select:                         [B4].Resize(SS, 12).ClearContents
 Columns("A:b").Insert Shift:=xlToRight:        [B1] = "SoThe"
 For Each Sh In ThisWorkbook.Worksheets
    If Left(Sh.Name, 1) = "T" And Len(Sh.Name) = 3 Then
        With [b65500].End(xlUp)
            Sh.Range(Sh.[b3], Sh.[b65500].End(xlUp)).Copy Destination:=.Offset(1)
        End With
    End If
 Next Sh
 Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[A1], Unique:=True
 Columns("A:A").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, DataOption1:=xlSortTextAsNumbers
 [A1].Resize(SS).Copy Destination:=[d3]
 Columns("A:B").Delete
 For Each Cls In Range([B4], [b65500].End(xlUp))
    For Each Sh In ThisWorkbook.Worksheets
        If Left(Sh.Name, 1) = "T" And Len(Sh.Name) = 3 Then
            Set Rng = Sh.Range(Sh.[b2], Sh.[b65500].End(xlUp))
            Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
            If Not sRng Is Nothing Then
                With Cls.Offset(, 1)
                    If .Value = "" Then .Value = sRng.Offset(, 7).Value
                End With
                With Cls.Offset(, 2)
                    .Value = .Value + sRng.Offset(, 40).Value
                    .Offset(, 1).Value = .Value + sRng.Offset(, 41).Value
                End With
            End If
        End If
    Next Sh
 Next Cls
End Sub

 

[firstsight8719]

Ai chỉ thêm cho e với, sao e chép vào marco mà không được, làm sao đây?

 

[Lê Duy Thương]

MÀY MÒ CODE CỦA CÁC CAO THỦ CHẾ ĐƯỢC THẾ NÀY KHÔNG BIẾT CÓ ĐÚNG KHÔNG

Sub THOP()
  Dim Dic, Sh As Worksheet, iRow As Long, i As Long, j As Long
  Dim Arr(), TmpArr
  On Error Resume Next
  Application.ScreenUpdating = 0
  Sheets("THop").Range("A:AG").ClearContents
  With CreateObject("Scripting.Dictionary")
    For Each Sh In Worksheets
      If Sh.Name <> "THop" Then
        TmpArr = Sh.Range(Sh.[b2], Sh.[B65536].End(xlUp)).Resize(, 52).Value
        For iRow = 1 To UBound(TmpArr, 1)
          If Not IsEmpty(TmpArr(iRow, 1)) Then
            If Not .Exists(TmpArr(iRow, 1)) Then
              i = i + 1
              .Add TmpArr(iRow, 1), i
              ReDim Preserve Arr(1 To 52, 1 To i)
              For j = 1 To 52
                Arr(j, i) = TmpArr(iRow, j)
              Next
            Else
              Arr(41, .Item(TmpArr(iRow, 1))) = Arr(41, .Item(TmpArr(iRow, 1))) + TmpArr(iRow, 41)
              Arr(42, .Item(TmpArr(iRow, 1))) = Arr(42, .Item(TmpArr(iRow, 1))) + TmpArr(iRow, 42)
            End If
          End If
        Next
      End If
    Next
  End With
  With Sheets("THop")
  .Range("B4").Resize(i, 52) = WorksheetFunction.Transpose(Arr)
  .Range("K:AO").Delete Shift:=xlToLeft
  .Range("K4:L4").Value = Sheet1.Range("AP2:AQ2").Value
  .Columns("A:AQ").EntireColumn.AutoFit
  .Range("A4") = "STT"
  .Range("A5").Resize(i - 1).Value = Evaluate("ROW(R:R)")
End With
Application.ScreenUpdating = 1
End Sub

 

[firstsight8719]

Mình cũng chưa làm được, chắc do phần lập trình mình còn yếu quá !!! dù sao cũng cảm ơn mấy bạn nhìu