Extracting xls files from a folder directory

[vicedo]

Hi guys,

Please I have this VBA code which combines multiple excel workbooks into one excel sheet as long as all the xls files are in one folder and no other file formats in it. Here is the code

Option Explicit
Public strPath As String
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
'Description: Combines all files in a folder to a master file.
Sub MergeFiles()
Dim path As String, ThisWB As String, lngFilecounter As Long
Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
Dim Filename As String, Wkb As Workbook
Dim CopyRng As Range, Dest As Range
Dim RowofCopySheet As Integer

RowofCopySheet = 2 ' Row to start on in the sheets you are copying from

ThisWB = ActiveWorkbook.Name

path = GetDirectory("Select a folder containing Excel files you want to merge")

Application.EnableEvents = False
Application.ScreenUpdating = False

Set shtDest = ActiveWorkbook.Sheets(1)
Filename = Dir(path & "\*.xls", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = vbNullString
If Not Filename = ThisWB Then
Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
CopyRng.Copy Dest
Wkb.Close False
End If

Filename = Dir()
Loop

Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

MsgBox "Done!"
End Sub

Now I have a folder which contains both XLS files and TXT files and all I want is to tilt this code a bit to only extract all XLS files in the directory accordingly

 

[Darren Bartrup]

This should do the trick:

Public Sub MergeFiles()


    Dim sFolder As String
    Dim colFiles As Collection
    Dim vFile As Variant
    Dim wrkBk As Workbook
    Dim rMergeLastCell As Range
    Dim rReportLastCell As Range
    
    Set colFiles = New Collection
    
    sFolder = GetFolder() 'Ask for the folder.
    EnumerateFiles sFolder, "*.xls*", colFiles 'Get all Excel files in the folder.
    
    For Each vFile In colFiles
        Set wrkBk = Workbooks.Open(vFile, False) 'Open each file in turn.
        Set rReportLastCell = LastCell(wrkBk.Worksheets(1)) 'Find the last cell in the file.
        
        If rReportLastCell.Row > 1 Then 'Only continue if the sheet contains data.
            Set rMergeLastCell = LastCell(ThisWorkbook.Worksheets(1)) 'Find last cell in final report.
            With wrkBk.Worksheets(1)
                .Range(.Cells(2, 1), rReportLastCell).Copy _
                    Destination:=ThisWorkbook.Worksheets(1).Cells(rMergeLastCell.Row + 1, 1) 'Copy the data.
            End With
        End If
        
        wrkBk.Close False
        
    Next vFile
    
End Sub


'---------------------------------------------------------------------------------------
' Procedure : GetFolder
' Author    : Darren Bartrup-Cook
' Date      : 25/10/2013
' Purpose   : Returns the file path of the selected folder.
' To Use    : vFolder = GetFolder()
'           : vFolder = GetFolder("S:\Bartrup-CookD\Customer Services Phone Reports")
'---------------------------------------------------------------------------------------
Function GetFolder(Optional startFolder As Variant = -1) As Variant
    Dim fldr As FileDialog
    Dim vItem As Variant
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If startFolder = -1 Then
            .InitialFileName = Application.DefaultFilePath
        Else
            If Right(startFolder, 1) <> "\" Then
                .InitialFileName = startFolder & "\"
            Else
                .InitialFileName = startFolder
            End If
        End If
        If .Show <> -1 Then GoTo NextCode
        vItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = vItem
    Set fldr = Nothing
End Function


'----------------------------------------------------------------------------------
' Procedure : EnumerateFiles
' Author    : Darren Bartrup-Cook
' Date      : 17/12/2014
' Purpose   : Places all file names with FileSpec extension into a collection.
' To Use    : EnumerateFiles "S:\Bartrup-CookD\Trackers", "*.xls", colFiles
'-----------------------------------------------------------------------------------
Sub EnumerateFiles(ByVal sDirectory As String, _
    ByVal sFileSpec As String, _
    ByRef cCollection As Collection)


    Dim sTemp As String
    
    If InStrRev(sDirectory, "\") <> Len(sDirectory) Then
        sDirectory = sDirectory & "\"
    End If
    
    sTemp = Dir$(sDirectory & sFileSpec)
    Do While Len(sTemp) > 0
        cCollection.Add sDirectory & sTemp
        sTemp = Dir$
    Loop
End Sub


'---------------------------------------------------------------------------------------
' Procedure : LastCell
' Author    : Darren Bartrup-Cook
' Date      : 26/11/2013
' Purpose   : Finds the last cell containing data or a formula within the given worksheet.
'             If the Optional Col is passed it finds the last row for a specific column.
'---------------------------------------------------------------------------------------
Public Function LastCell(wrkSht As Worksheet, Optional Col As Long = 0) As Range


    Dim lLastCol As Long, lLastRow As Long
    
    On Error Resume Next
    
    With wrkSht
        If Col = 0 Then
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
        Else
            lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            lLastRow = .Columns(Col).Find("*", , , , xlByColumns, xlPrevious).Row
        End If
        
        If lLastCol = 0 Then lLastCol = 1
        If lLastRow = 0 Then lLastRow = 1
        
        Set LastCell = wrkSht.Cells(lLastRow, lLastCol)
    End With
    On Error GoTo 0
    
End Function

 

[vicedo]

Got it

Thanks Darren

 

[Darren Bartrup]

Glad to help.