Snasui Excel Forum

Code: Select all

Sub CollectAllFile()
Dim nb As Workbook, ob As Workbook
Dim r As Range
Dim nb1 As Range, nb2 As Range
Dim nb3 As Range, nb4 As Range
Dim i As Integer, lng As Long
Dim FileSelected As Variant
    
Application.ScreenUpdating = False
On Error GoTo MsgError
lng = Rows.Count
Set ob = Workbooks("summary.xlsm")
FileSelected = Application.GetOpenFilename("Excel Files (*.xlsx),*.xlsx", , _
       "Select your Excel's File", , True)
For i = 1 To UBound(FileSelected)
    Workbooks.Open Filename:=(FileSelected(i)), UpdateLinks:=0
    Set nb = ActiveWorkbook
    With nb.Worksheets("Data")
        Set nb1 = .Range("G3")
        Set nb2 = .Range("C12:C23")
        Set nb3 = .Range("E10:N10")
        Set nb4 = .Range("E12:N23")
    End With
    Set r = ob.Worksheets("Summary").Range("A" & lng).End(xlUp).Offset(2, 0)
    nb1.Copy: r.PasteSpecial xlPasteValues
    nb2.Copy: r.Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    nb3.Copy: r.Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    nb4.Copy: r.Offset(1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Application.CutCopyMode = False
    nb.Close False
Next i
Application.ScreenUpdating = True
MsgBox "Finish."
Exit Sub
    
MsgError:
    MsgBox "Please try again."
    Exit Sub

End Sub