Xuất File tổng hợp từ nhiều Table có cùng cấu trúc

[sunnyhuu]

Chào các bạn,
Mình có vấn đề nhỏ cần trợ giúp như sau:
File của mình có sheet BANGGIA, trong sheet này có nhiều table (Mình có đặt tên: BANGGIA1, BANGGIA2,...) chứa dữ liệu có cùng cấu trúc. Mình muốn tạo 1 nút nhấn hoặc 1 cách nào đó để tổng hợp tất cả dữ liệu của các table qua Sheet TONGHOP hoặc File Excel mới, và có bỏ 1 số cột không cần thiết.
Mình đính kèm file mẫu cho các bạn xem thử.
Cám ơn các bạn.

 

[sunnyhuu]

Có ai giúp mình được không? hiện tại mình đang dùng vlookup tạm. hơi bất tện

 

[vanthinh3101]

Có ai giúp mình được không? hiện tại mình đang dùng vlookup tạm. hơi bất tện

Code sau dùng để tổng hợp dữ liệu ra 1 sheet mới

Sub Report()
    Dim sArr(), dArr(), Header As Range, Ws As Worksheet
    Dim I As Long, J As Long, K As Long, lR As Long
    
    With Sheet1
        Set Header = .Range("A3:R3")
        lR = .Range("A" & Rows.Count).End(xlUp).Row
        sArr = .Range("A4:R" & lR).Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
    
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 1) <> "MODEL" And Len(sArr(I, 1)) Then
            K = K + 1
            For J = 1 To UBound(sArr, 2)
                dArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
    
    If K Then
        Set Ws = Sheets.Add(, Sheets(Sheets.Count))
        With Ws
            '.Name = ""
            Header.Copy .Range("A2")
            .Range("A3").Resize(K, UBound(sArr, 2)) = dArr
            .Range("A2").CurrentRegion.EntireColumn.AutoFit
            .Range("E:E, F:F, I:I, L:L").Delete
        End With
    End If
    Set Header = Nothing: Set Ws = Nothing
    MsgBox "Done", vbInformation, "GPE"
End Sub

 

[SA_DQ]

Thêm 1 macro rùa bò này để bạn tham khảo:

Sub CopyToTongHop()
Dim Rng As Range, sRng As Range, Cls As Range, dArr()
Dim Rws As Long, J As Long, W As Integer, Col As Byte, Cot As Byte, Dg As Long, Tmr As Double
Dim MyAdd As String

Rws = [A65500].End(xlUp).Row:                       Tmr = Timer()
Set Rng = [A2].Resize(Rws + 9)
Col = [b3].CurrentRegion.Columns.Count
ReDim Arr(1 To Rws, 1 To Col - 3)
Sheets("TongHop").[A3].CurrentRegion.Offset(2).ClearContents
Application.ScreenUpdating = False
Set sRng = Rng.Find("MODEL", , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
    MyAdd = sRng.Address
    Do
        Dg = sRng.End(xlDown).Row - sRng.Row + 1
        dArr() = sRng.Offset(1).Resize(Dg, Col)
        For J = 1 To UBound(dArr())
            If dArr(J, 1) = "" Then Exit For
            W = W + 1:
            For Cot = 1 To 4
                Arr(W, Cot) = dArr(J, Cot)
            Next Cot
            For Cot = 7 To 8
                Arr(W, Cot - 2) = dArr(J, Cot)
            Next Cot
            For Cot = 10 To Col
                Arr(W, Cot - 3) = dArr(J, Cot)
            Next Cot
        Next J
        Set sRng = Rng.FindNext(sRng)
    Loop While sRng.Address <> MyAdd
End If
If W Then
     Sheets("TongHop").[A3].Resize(W, Col - 3).Value = Arr()
End If
Application.ScreenUpdating = True
MsgBox Timer() - Tmr
End Sub

 

[sunnyhuu]

Code sau dùng để tổng hợp dữ liệu ra 1 sheet mới

Sub Report()
    Dim sArr(), dArr(), Header As Range, Ws As Worksheet
    Dim I As Long, J As Long, K As Long, lR As Long
   
    With Sheet1
        Set Header = .Range("A3:R3")
        lR = .Range("A" & Rows.Count).End(xlUp).Row
        sArr = .Range("A4:R" & lR).Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
   
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 1) <> "MODEL" And Len(sArr(I, 1)) Then
            K = K + 1
            For J = 1 To UBound(sArr, 2)
                dArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
   
    If K Then
        Set Ws = Sheets.Add(, Sheets(Sheets.Count))
        With Ws
            '.Name = ""
            Header.Copy .Range("A2")
            .Range("A3").Resize(K, UBound(sArr, 2)) = dArr
            .Range("A2").CurrentRegion.EntireColumn.AutoFit
            .Range("E:E, F:F, I:I, L:L").Delete
        End With
    End If
    Set Header = Nothing: Set Ws = Nothing
    MsgBox "Done", vbInformation, "GPE"
End Sub

Cám ơn bạn nhiều

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

Thêm 1 macro rùa bò này để bạn tham khảo:

Sub CopyToTongHop()
Dim Rng As Range, sRng As Range, Cls As Range
Dim Rws As Long, J As Long, W As Integer, Col As Byte, Cot As Byte, Dg As Long
Dim MyAdd As String

Rws = [A65500].End(xlUp).Row
Set Rng = [A2].Resize(Rws + 9)
Col = [b3].CurrentRegion.Columns.Count
ReDim Arr(1 To Rws, 1 To Col - 4)
Sheets("TongHop").[A3].CurrentRegion.Offset(1).ClearContents
Application.ScreenUpdating = False
Set sRng = Rng.Find("MODEL", , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
    MyAdd = sRng.Address
    Do
        For Each Cls In Range(sRng.Offset(1), sRng.Offset(1).End(xlDown))
            W = W + 1:                                              Dg = Cls.Row
            For Cot = 1 To 4
                Arr(W, Cot) = Cells(Dg, Cot).Value                  '4 Côt Dâu Tiên     '
            Next Cot
            For Cot = 7 To 8
                Arr(W, Cot - 2) = Cells(Dg, Cot).Value
            Next Cot
            For Cot = 10 To 11
                Arr(W, Cot - 3) = Cells(Dg, Cot).Value
            Next Cot
            For Cot = 13 To Col
                Arr(W, Cot - 4) = Cells(Dg, Cot).Value          'Các Côt Cuói Cùng     '
            Next Cot
        Next Cls
        Set sRng = Rng.FindNext(sRng)
    Loop While sRng.Address <> MyAdd
End If
If W Then
     Sheets("TongHop").[A3].Resize(W, Col - 4).Value = Arr()
End If
Application.ScreenUpdating = True
End Sub

Cám ơn bạn rất nhiều, để mình thử xem

 

[sunnyhuu]

Code sau dùng để tổng hợp dữ liệu ra 1 sheet mới

Sub Report()
    Dim sArr(), dArr(), Header As Range, Ws As Worksheet
    Dim I As Long, J As Long, K As Long, lR As Long
   
    With Sheet1
        Set Header = .Range("A3:R3")
        lR = .Range("A" & Rows.Count).End(xlUp).Row
        sArr = .Range("A4:R" & lR).Value
    End With
    ReDim dArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2))
   
    For I = 1 To UBound(sArr, 1)
        If sArr(I, 1) <> "MODEL" And Len(sArr(I, 1)) Then
            K = K + 1
            For J = 1 To UBound(sArr, 2)
                dArr(K, J) = sArr(I, J)
            Next J
        End If
    Next I
   
    If K Then
        Set Ws = Sheets.Add(, Sheets(Sheets.Count))
        With Ws
            '.Name = ""
            Header.Copy .Range("A2")
            .Range("A3").Resize(K, UBound(sArr, 2)) = dArr
            .Range("A2").CurrentRegion.EntireColumn.AutoFit
            .Range("E:E, F:F, I:I, L:L").Delete
        End With
    End If
    Set Header = Nothing: Set Ws = Nothing
    MsgBox "Done", vbInformation, "GPE"
End Sub

Bạn có thể giúp mình 1 vấn đề nữa không? là giữa các table mình có chèn thêm 1 header, khi xuất qua nó lại lấy luôn các header đó (các header mình tô đỏ trong file kèm)
Một lần nữa cảm ơn bạn rất nhiều

 

[vanthinh3101]

Bạn có thể giúp mình 1 vấn đề nữa không? là giữa các table mình có chèn thêm 1 header, khi xuất qua nó lại lấy luôn các header đó (các header mình tô đỏ trong file kèm)
Một lần nữa cảm ơn bạn rất nhiều

Tôi chưa biết được nội dung header mà bạn nhắc đến.
Nhưng nếu là dạng Mergecell như dữ liệu bạn đưa thì vẫn code ở bài #3, bạn sửa như sau:
Từ:

If sArr(I, 1) <> "MODEL" And Len(sArr(I, 1)) Then

Thành:

If sArr(I, 1) <> "MODEL" And Len(sArr(I, 1)) * Len(sArr(I, 2)) Then

 

[sunnyhuu]

Help Mình thêm vấn đề nữa được không bạn, cũng file này, giờ mình muốn xuất Table BANGGIA1 và BANGGIA2 ra sheet TIVI, Table BANGGIA3 và BANGGIA4 ra sheet LOA, BANGGIA5 ra sheet TAINGHE,....
Ý là mình muốn xuất gom 2 table ra 1 sheet hoặc 3 table ra 1 sheet hoặc 1 table ra 1 sheet, và các sheet mới nằm ở file excel mới, có bỏ bớt những cột không cần thiết (GIA NVBH, KM3, SONY,..)
Xin cám ơn và sẽ hậu tạ bạn.