Wednesday, October 30, 2013

Copy Range from Another Workbook through VBA

Option Explicit
Dim fso As FileSystemObject
Dim fl As File
Dim fldr As Folder
Public wb As Workbook, wbnew As Workbook
Dim fldrpath As String
Sub trackSheet()
Set wb = ThisWorkbook
On Error GoTo ErrorHandler
Set fso = New Scripting.FileSystemObject
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choose Folder"
Application.FileDialog(msoFileDialogFolderPicker).Show
fldrpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
Set fldr = fso.GetFolder(fldrpath)
For Each fl In fldr.Files
    wb.Sheets.Add after:=Sheets(Sheets.Count)
 
    wb.Sheets(Sheets.Count).Name = fl.Name
Call copySheet(fldrpath & fl.Name)


Next
Set wb = Nothing
Exit Sub
ErrorHandler:

MsgBox "Select Folder"

End Sub



Sub copySheet(ByVal pathname As String)
 i = InStr(pathname, ".")
 extn = Mid(pathname, i, Len(pathname) - (i - 1))
 If extn Like ".xl*" Then
        Set wbnew = Workbooks.Open(pathname)
        Application.DisplayAlerts = False
        wbnew.Sheets(1).UsedRange.Copy Destination:=wb.Sheets(wb.Sheets.Count).Range("A1")
        wb.Save
        wbnew.Close
 End If
End Sub





https://drive.google.com/file/d/0B23eJ2xd9ODycEVOclQ5TmJkYnM/edit?usp=sharing

No comments:

Post a Comment