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
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