Lấy dữ liệu từ nhiều vào 1 sheet ?

Chia sẻ bởi:hands

★★★★★

‹ Tổng hợp dữ liệu theo nhóm (từ... Nhờ giúp đỡ code VBA giải quyết... ›

Quảng cáo

Xin chào tất các bạn,

Tôi đang vướng mắc bài toán, xin phép được giải thích rõ trong file đính kèm:
https://www.mediafire.com/file/l1e9nh42nnbq7t3/TTal.xlsxCơ quan của Oanh Thơ nghèo nên không có kinh phí mua phần mềm , do vậy mỗi người phải tự thân vận động bạn ạ.
Đáng buồn nhất là Oanh Thơ hỏi xong áp dụng OK là quên luôn không nhớ gì hết trơn ạ , mặc dù là đôi lúc đã dành tìm hiểu đến (T_T)

Sau 1 thời gian tham gia diễn đàn Oanh thơ cũng cảm thấy nơi đây: Thầy nhiều hơn Trò bạn ah 🙂
Một môi trường rất hữu ích, cảm giác thật tuyệt vời.

Rất mong các bạn xem file và tìm cách giúp đỡ.

Sub TongHop()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Const TEN0 As String = "Tonghop" 'Ten sheet Tonghop
Dim wb As Workbook, ws As Worksheet, NB As String, NS As String
Dim tmp() As Variant, z As Long, r As Long, T As Variant
Dim KQ() As Variant, j As Long, k As Long, kMax As Long, maWS As String, tenWS As String
Set wb = ThisWorkbook: NB = wb.Name: NB = Left(NB, Len(NB) - 5)
ReDim KQ(1 To 1000000, 1 To 50)
For Each ws In wb.Worksheets
    NS = ws.Name
    If NS <> TEN0 Then      'Kiem tra: ten sheet <> ten sheet Tonghop
        z = ws.Range("I" & ws.Rows.Count).End(xlUp).Row
        If z > 9 Then
            Erase tmp
            tmp = ws.Range("E10:AW" & z).Value2: z = UBound(tmp, 1): kMax = UBound(tmp, 2)
            maWS = ws.Range("K6"): tenWS = ws.Range("K7")
            For r = 1 To z
                T = tmp(r, 5)
                If T <> Empty Then
                    j = j + 1
                    For k = 1 To kMax
                        KQ(j, k + 5) = tmp(r, k)
                    Next k
                    KQ(j, 1) = NB:      KQ(j, 2) = NS
                    KQ(j, 3) = maWS:    KQ(j, 4) = tenWS
                End If
            Next r
        End If
    End If
Next ws
If j Then
    Sheets(TEN0).Range("B5").Resize(1000000, 50).ClearContents
    Sheets(TEN0).Range("B5").Resize(j, 50) = KQ
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

p/s: Mỗi ngày oánh quả lẻ một bài rồi sẽ xong việc thôi…