VBA gộp nhiều sheet thành 1 sheet nhưng chỉ lấy 1 phần (1 người xem)

[haup299]

Chào các bạn,
Mình muốn tổng hợp dữ liệu:
Mình có 1 file DATA có rất nhiều sheet
Bây giờ muốn làm 1 file và gán macro vào, khi nhấn nút sẽ hiện hộp thoại yêu cầu chon file DATA
Sau đó nó sẽ gộp tất cả các sheet của file DATA lại,
nhưng mỗi sheet chỉ lấy dữ liệu tại 1 khu vực chứ không phải lấy hết cả sheet
Điều kiện lấy mình chú thích trong file

Rất mong được giúp đỡ của các bạn

 

[haup299]

Option Explicit

Public Sub GPE()
Dim Ws As Worksheet, sArr, dArr(1 To 10000, 1 To 12), I As Long, J As Long, K As Long
Dim R1 As Long, R2 As Long, Item, lR As Long, Rng As Range, PNO As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File", vbInformation, "----Mr.GPE----"
        Exit Sub
    End If
   
    For Each Item In .SelectedItems
        If Left(Item, 1) <> "~" Then
        Application.DisplayAlerts = False
        Application.AskToUpdateLinks = False
        With Workbooks.Open(Item)
            For Each Ws In .Worksheets
                With Ws
                    lR = .Range("A" & Rows.Count).End(3).Row
                    Set Rng = .Range("A1:A" & lR)
                    R1 = Application.Match("2. ASSET SUMMARY", Rng, 0) + 3
                    R2 = Application.Match("3. LABOUR", Rng, 0) - 3
                    sArr = .Range("A" & R1 & ":A" & R2).Resize(, 12).Value
                    PNO = .[B1].Value
                End With
                    For I = 1 To UBound(sArr)
                        If Len(sArr(I, 1)) Then
                            K = K + 1
                            dArr(K, 1) = PNO
                            For J = 2 To 12
                                dArr(K, J) = sArr(I, J)
                            Next
                        End If
                    Next
            Next
            .Close
        End With
        If K Then
            Range("A1").CurrentRegion.Offset(1).ClearContents
            Range("A2").Resize(K, 12).Value = dArr
        End If
        End If
    Next
End With
MsgBox "Done!"
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
End Sub

Cảm ơn bạn nhiều nhé

 

[haup299]

Option Explicit

Public Sub GPE()
Dim Ws As Worksheet, sArr, dArr(1 To 10000, 1 To 12), I As Long, J As Long, K As Long
Dim R1 As Long, R2 As Long, Item, lR As Long, Rng As Range, PNO As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = True
    .Filters.Add "Microsoft Excel Files", "*.xls*", 1
    If Not .Show = -1 Then
        MsgBox "Ban chua chon File", vbInformation, "----Mr.GPE----"
        Exit Sub
    End If
   
    For Each Item In .SelectedItems
        If Left(Item, 1) <> "~" Then
        Application.DisplayAlerts = False
        Application.AskToUpdateLinks = False
        With Workbooks.Open(Item)
            For Each Ws In .Worksheets
                With Ws
                    lR = .Range("A" & Rows.Count).End(3).Row
                    Set Rng = .Range("A1:A" & lR)
                    R1 = Application.Match("2. ASSET SUMMARY", Rng, 0) + 3
                    R2 = Application.Match("3. LABOUR", Rng, 0) - 3
                    sArr = .Range("A" & R1 & ":A" & R2).Resize(, 12).Value
                    PNO = .[B1].Value
                End With
                    For I = 1 To UBound(sArr)
                        If Len(sArr(I, 1)) Then
                            K = K + 1
                            dArr(K, 1) = PNO
                            For J = 2 To 12
                                dArr(K, J) = sArr(I, J)
                            Next
                        End If
                    Next
            Next
            .Close
        End With
        If K Then
            Range("A1").CurrentRegion.Offset(1).ClearContents
            Range("A2").Resize(K, 12).Value = dArr
        End If
        End If
    Next
End With
MsgBox "Done!"
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
End Sub

Bạn ơi, khi mình chọn File Data nào nhiều sheet bị lỗi
Ví dụ chọn cùng lúc 5 file, mỗi file khoảng 8 sheet thì ok
Còn chọn 1 file 46 sheet thì bị lỗi
Nên ko biết giới hạn là bao nhiêu và có thể chọn thoai mái dc ko

 

[Skyblue1910]

Chào các bạn.
Mình muốn làm sheet tổng hợp, lấy dữ liệu từ rất nhiều sheet.
Các bạn có thể giúp mình với không ạ ? mình có gửi file đính kèm các bạn tham khảo nha.
thông tin mình cần lấy là những phần tô màu vàng ở sheet sumary từ các sheet thành phần nha.
Cảm ơn các bạn nhiều.
Trường hợp mình có thềm sản phẩm mới, có thêm sheet mới thì sẽ làm như thế nào ạ.

 

[haup299]

Chào các bạn.
Mình muốn làm sheet tổng hợp, lấy dữ liệu từ rất nhiều sheet.
Các bạn có thể giúp mình với không ạ ? mình có gửi file đính kèm các bạn tham khảo nha.
thông tin mình cần lấy là những phần tô màu vàng ở sheet sumary từ các sheet thành phần nha.
Cảm ơn các bạn nhiều.
Trường hợp mình có thềm sản phẩm mới, có thêm sheet mới thì sẽ làm như thế nào ạ.

Bạn nên tạo topic mới, tiêu đề mới, sẽ có nhiều người vào xem. Vì mỗi topic sẽ có 1 cách giải quyết riêng.

 

[Skyblue1910]

Bạn nên tạo topic mới, tiêu đề mới, sẽ có nhiều người vào xem. Vì mỗi topic sẽ có 1 cách giải quyết riêng.

Cảm ơn bạn nha.