Tổng hợp file gồm nhiều sheet thành 1 sheet "tonghop" (1 người xem)

[tttu056]

Mình có 1 file gồm nhiều sheet, bi giờ mình muốn gọp thành 1 sheet tonghop theo như mẫu định kèm. Các bác có đoạn Macro hay cách nào khác không cho mình xin để chạy sheet

 

[concogia]

Mình có 1 file gồm nhiều sheet, bi giờ mình muốn gọp thành 1 sheet tonghop theo như mẫu định kèm. Các bác có đoạn Macro hay cách nào khác không cho mình xin để chạy sheet "tonghop" này cho nhanh. thanks

Thử sửa, thêm, bớt dữ liệu ở các sheet "T.." rồi chọn Sheet "tonghop" xem kết quả
Chú ý: Dữ liệu trong vùng [F2:K2] ở Sheet "tonghop" phải giống tên các sheet "T.."
Thân

 

[tttu056]

Thanks concogia. Mình không rành về VBA nên cho mình hỏi xíu. Bạn lấy cột Họ tên hay cột SS làm chuẩn để cho ra các kết quả khác vậy, nếu cần chỉnh mình phải chỉnh ntn. Mình muốn thêm nhiều sheet nữa thì mình phải chỉnh như thế nào. VD: T1, T2 ... T24. View attachment Tong hop.xls

 

[concogia]

Thanks concogia. Mình không rành về VBA nên cho mình hỏi xíu. Bạn lấy cột Họ tên hay cột SS làm chuẩn để cho ra các kết quả khác vậy, nếu cần chỉnh mình phải chỉnh ntn. Mình muốn thêm nhiều sheet nữa thì mình phải chỉnh như thế nào. VD: T1, T2 ... T24. View attachment 76739

Mình lấy cột Tên làm chuẩn vì không biết dữ liệu của bạn cột nào là duy nhất
Hinh như la cột C (SS), mình sửa code lại lấy cột C làm chuẩn nhé
Bạn làm thế này:
Right Click vào sheet "tonghop" ==> View Code ==> chép cái này vào

Private Sub Worksheet_Activate()
Dim Vung, d, Mg(), Sh, K, I, kK, Thang, iThang
    Set d = CreateObject("scripting.dictionary"): Set Thang = Range([b2], [IV2].End(xlToLeft))
    For Each Sh In Worksheets
        If Sh.Name <> "tonghop" Then K = K + Sh.Range(Sh.[b2], Sh.[b10000].End(xlUp)).Rows.Count
    Next Sh
        ReDim Mg(1 To K, 1 To Thang.Columns.Count)
        For Each Sh In Worksheets
            If Sh.Name <> "tonghop" Then            
                iThang = Application.WorksheetFunction.Match(Sh.Name, Thang, 0)
                Vung = Sh.Range(Sh.[b2], Sh.[b10000].End(xlUp)).Resize(, 5).Value
                    For I = 1 To UBound(Vung)
                        If Not d.exists(Vung(I, 2)) Then
                            kK = kK + 1
                            d.Add Vung(I, 2), kK
                            Mg(kK, 1) = Vung(I, 1): Mg(kK, 2) = Vung(I, 2): Mg(kK, 3) = Vung(I, 3): Mg(kK, 4) = Vung(I, 4): Mg(kK, iThang) = Vung(I, 5)
                        Else
                            Mg(d.Item(Vung(I, 2)), iThang) = Vung(I, 5)
                        End If
                    Next I
            End If
    Next Sh
    [A3:K10000].ClearContents
    [B3].Resize(kK, 10) = Mg
    Range([B3], [b10000].End(xlUp)).Offset(, -1) = [row(A:A)]
End Sub

Bạn thêm dữ liệu các sheet mới rồi chọn sheet "tonghop" kiểm tra thử xem kết quả có Ok không nhé
Bi giờ bạn có thể chèn thêm bao nhiêu sheet nữa cũng được, cứ thử nhé, có gì bàn tiếp
Thân

 

[tttu056]

Khi nhập cột Họ tên, SS, ST, Năm sinh thì bên cột tổng hợp chạy được nhưng cột Tiền thì không nhảy. Nó bị sao vậy bạn.

 

[concogia]

Khi nhập cột Họ tên, SS, ST, Năm sinh thì bên cột tổng hợp chạy được nhưng cột Tiền thì không nhảy. Nó bị sao vậy bạn.

Nó bị sao vậy bạn.

Híc, nó bị....mình đưa lộn code. "Xó dzì" bạn nhé. Bạn chép lại code này giúp mình

Private Sub Worksheet_Activate()
Dim Vung, d, Mg(), Sh, K, I, kK, Thang, iThang
    Set d = CreateObject("scripting.dictionary"): Set Thang = Range([b2], [IV2].End(xlToLeft))
    For Each Sh In Worksheets
        If Sh.Name <> "tonghop" Then K = K + Sh.Range(Sh.[b2], Sh.[b10000].End(xlUp)).Rows.Count
    Next Sh
        ReDim Mg(1 To K, 1 To Thang.Columns.Count)
        For Each Sh In Worksheets
            If Sh.Name <> "tonghop" Then
                iThang = Application.WorksheetFunction.Match(Sh.Name, Thang, 0)
                Vung = Sh.Range(Sh.[b2], Sh.[b10000].End(xlUp)).Resize(, 5).Value
                    For I = 1 To UBound(Vung)
                        If Not d.exists(Vung(I, 2)) Then
                            kK = kK + 1
                            d.Add Vung(I, 2), kK
                            Mg(kK, 1) = Vung(I, 1): Mg(kK, 2) = Vung(I, 2): Mg(kK, 3) = Vung(I, 3): Mg(kK, 4) = Vung(I, 4): Mg(kK, iThang) = Vung(I, 5)
                        Else
                            Mg(d.Item(Vung(I, 2)), iThang) = Vung(I, 5)
                        End If
                    Next I
            End If
    Next Sh
    [A3:BW10000].ClearContents
    [B3].Resize(kK, Thang.Columns.Count) = Mg
    Range([B3], [b10000].End(xlUp)).Offset(, -1) = [row(A:A)]
End Sub

Thân

 

[LinDan]

Đoạn LastRow = Sh.Cells.Find(What:="*", After:=Sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row tôi chưa hiểu hết, xin thày cocogia giải thích hộ dùm?

Option Explicit
Function LastRow(Sh As Worksheet)
    On Error Resume Next
    LastRow = Sh.Cells.Find(What:="*", After:=Sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
    On Error GoTo 0
End Function
Function Lastcol(Sh As Worksheet)
    On Error Resume Next
    Lastcol = Sh.Cells.Find(What:="*", After:=Sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
    On Error GoTo 0
End Function
Sub CopyTheUsedRangeOfEachSheet()
    Dim Sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    On Error Resume Next
    If Len(ThisWorkbook.Worksheets.Item("Master").Name) = 0 Then
        On Error GoTo 0
        Application.ScreenUpdating = False
        Set DestSh = ThisWorkbook.Worksheets.Add
        DestSh.Name = "Master"
        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name <> DestSh.Name Then
                Last = LastRow(DestSh)
                Sh.UsedRange.Copy DestSh.Cells(Last + 1, "A")
                'Instead of this line you can use the code below to copy only the values
                'or use the PasteSpecial option to paste the format also.
                'With sh.UsedRange
                'DestSh.Cells(Last + 1, "A").Resize(.Rows.Count, _
                        '.Columns.Count).Value = .Value
                'End With
                'sh.UsedRange.Copy
                'With DestSh.Cells(Last + 1, "A")
                ' .PasteSpecial xlPasteValues, , False, False
                ' .PasteSpecial xlPasteFormats, , False, False
                ' Application.CutCopyMode = False
                'End With
            End If
        Next
        DestSh.Cells(1).Select
        Application.ScreenUpdating = True
    Else
        MsgBox "The sheet Master already exist"
    End If
End Sub

 

[traitimvocam]

E chào a/chị trên GPE,
Nhờ các cao thủ GPE có thể dùng công thức mà ko cần dùng VBA cho file này được ko ạ.
E cảm ơn a/chị rất nhiều.
Mong nhận được thư a/chị

 

[ChanhTQ@]

Tranh thủ lúc Cò đi vắng, ta đào, rồi ta bươi,. . .

Đoạn LastRow = Sh.Cells.Find(What:="*", After:=Sh.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row tôi chưa hiểu hết, xin thày cocogia giải thích hộ dùm?

Mình là cò gia khuyên bạn đọc bài này: http://www.giaiphapexcel.com/forum/...hững-ghi-chép-về-phương-thức-SpecialCells

Mà câu đáng lưu í nhất là:
"xlCellTypeLastCell. The last cell in the used range. Note this XlCellType will include empty cells that have had any of cells default format changed."

Cò già ta sợ cành cây coong, nên chắc ăn fải xài như zdậy đó bạn!

 

[traitimvocam]

Dear a chanhTQ,
Anh ơi anh có thể chuyển file trên thành công thức được ko anh? E ko biết dùng VBA. E cũng đang cần file đó để tổng hợp lắm.
Mong thư anh
E cam on anh

 

[ChanhTQ@]

(/ề công thức mà nói, có khi mình còn ẹ hơn cả bạn nữa ấy chứ!


(Rất xin lỗi & Nhờ các SMOD/MOD ngang qua xóa dùm bài SPAM này!)