OPENING ALL FILES IN A FOLDER

dk said:

Try running the GetFiles macro from this:-

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


Sub GetFiles()
    Dim strFolder As String, lngFilecounter As Long

    strFolder = GetDirectory("Please choose the folder that contains the files you wish to list")
    If Len(strFolder) = 0 Then Exit Sub

    With Application.FileSearch
        .NewSearch
        .LookIn = strFolder
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        If .FoundFiles.Count = 0 Then Exit Sub

        For lngFilecounter = 1 To .FoundFiles.Count

            Workbooks.Open .FoundFiles(lngFilecounter)

        Next lngFilecounter

    End With


End Sub

Click to expand...

dk said:

Something like this should work. It opens each workbook, copies everything on the first sheet expect from the header and pastes it into a destination workbook. Give it a go and let me know if it works.

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


Sub MergeFiles()
    Dim strFolder As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet
    Dim wbSource As Workbook

    strFolder = GetDirectory("Select a folder containing Excel files you want to merge")
    If Len(strFolder) = 0 Then Exit Sub

    'Create a new workbook.  This will be for the merged data
    Set wbDest = Workbooks.Add
    Set shtDest = wbDest.Sheets(1)

    With Application.FileSearch
        .NewSearch
        .LookIn = strFolder
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        If .FoundFiles.Count = 0 Then Exit Sub

        For lngFilecounter = 1 To .FoundFiles.Count

            Set wbSource = Workbooks.Open(.FoundFiles(lngFilecounter))
            ActiveSheet.Range(Cells(2, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)).Copy
            shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).PasteSpecial xlPasteAll
            wbSource.Close False
        Next lngFilecounter

    End With


End Sub

Click to expand...

dk said:

Replace this line:-

ActiveSheet.Range(Cells(2, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)).Copy

with this line:-

ActiveSheet.Range(Cells(3, 1), Cells(1000, ActiveSheet.UsedRange.Columns.Count)).Copy

Click to expand...

radar2000 said:

dk said:

Replace this line:-

ActiveSheet.Range(Cells(2, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count)).Copy

with this line:-

ActiveSheet.Range(Cells(3, 1), Cells(1000, ActiveSheet.UsedRange.Columns.Count)).Copy

Click to expand...

Thanks for your reply!

It did exactly what I had asked...but a little to good :wink:

I should had specified that I needed it to combine everything between row 3 and 1000 except for blanks. As it is currently capturing the blank rows.

Could you possibly tweak your macro? Please?
Thanks once again.

Click to expand...