Friday, May 31, 2013

A simple VBA in Excel 2010 to import each CSV file as a tab in XLS

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