Sub ImportAllCsvInDirectory()
'
' Copied from: http://www.excelforum.com/excel-programming-vba-macros/504512-import-multiple-csv-files-into-current-workbook-as-separate-sheets.html
'
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
'Fill in the path\folder where the files are
'on your machine
'MyPath = "c:\Data"
MyPath = GetFolder("c:\")
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.csv")
'If Not FilesInPath = False Then
If FilesInPath = "" Then
MsgBox "No files to consolidate"
Exit Sub
End If
On Error GoTo CleanUp
Application.ScreenUpdating = False
Set basebook = ThisWorkbook
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
mybook.Worksheets(1).Copy after:= _
basebook.Sheets(basebook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = mybook.Name
On Error GoTo 0
' You can use this if you want to copy only the values
' With ActiveSheet.UsedRange
' .Value = .Value
' End With
mybook.Close savechanges:=False
Next Fnum
End If
CleanUp:
Application.ScreenUpdating = True
SaveAsNewFile
End Sub
'
' Copied from: http://www.mrexcel.com/forum/excel-questions/294728-browse-folder-visual-basic-applications.html
'
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
'
'
Sub SaveAsNewFile()
Dim wb As Workbook
Dim NewFileName As String
Dim NewFileFilter As String
Dim myTitle As String
Dim FileSaveName As Variant
Dim NewFileFormat As Long
Set wb = ThisWorkbook
'Use following code to set to workbook other than this one
'Set wb = Workbooks("My Test Save As File.xlsm")
If Application.Version >= 12 Then 'Version 12 is xl2007
'Note: If file extension not included in B18 then concatenate it
'NewFileName = wb.Sheets("Sheet1").Range("B18").Value & ".xlsm"
NewFileFilter = "Excel Macro-Enable Workbook (*.xlsm), *.xlsm"
'The value 52 is substituted in next line for the constant _
xlOpenXMLWorkbookMacroEnabled because earlier versions of _
excel will not recognize the constant and code will error.
NewFileFormat = 52
Else
'Note: If file extension not included in B18 then concatenate it
'NewFileName = wb.Sheets("Sheet1").Range("B18").Value & ".xls"
NewFileFilter = "Excel 97-2003 Workbook (*.xls), *.xls"
'Because xlNormal is an earlier version constant, later versions _
of excel will recognize it.
NewFileFormat = xlNormal
End If
myTitle = "Navigate to the required folder"
FileSaveName = Application.GetSaveAsFilename _
(InitialFileName:=NewFileName, _
FileFilter:=NewFileFilter, _
Title:=myTitle)
If Not FileSaveName = False Then
wb.SaveAs Filename:=FileSaveName, _
FileFormat:=NewFileFormat
Else
MsgBox "File NOT Saved. User cancelled the Save."
End If
End Sub
'
'
Sub OpenFile()
Dim sFilename As String
sFilename = Application.GetOpenFilename("Excel files (*.xls), *.xls")
If Not sFilename = False Then
Workbooks.Open sFilename
Else
MsgBox "File NOT Saved. User cancelled the Save."
End If
End Sub
No comments:
Post a Comment