Multi excel files into one WORKSHEET 1

[gritz]

I would like to combine multiple excel files into one worksheet using an automatic process in Excel 97. The number of rows in each file can vary, but the columns are always the same. I can create multiple sheets instead of multiple files, if that makes it any easier, but I need to end up with one sheet so that I can generate a space delimited file.

 

[KenWright]

Give us some more details. What columns, How many files roughly? Do you want say 3 columns of data from every file put into firstly Cols A,B,C, then D,E,F, then G,H,I and so on, or do you want say the first 3 columns of every file put into the same 3 columns in the master file but all underneath each other.

Regards
Ken...............

 

[gritz]

There are always 6 columns, A through F. There would be about 15 files, give or take a few, and I would want all of the data to end up in the same 6 columns of the master file, underneath each other.

 

[KenWright]

Sorry, should have asked - Is the data in every column the same length in any one particular file. I know it is different in different files, but of you have data in say A1:A124, will you also have data in B1:B124, C1:C124, D1124 and so on.

Regards
Ken............

 

[KenWright]

OK, create a new file with two sheets. Call one 'Initialise' and the other 'Summary'


Copy all of the routine below down to the line that says 'Copy Above Here' and then paste it into a single module in your workbook. Then put a button in the mioddle of the 'Initialise' sheet and assign the macro CopyMultipleFiles() to it.

The GetDirectory code is thanks to John Walkenbach and his book Excel Power programming with VBA 2002 - Great book for all levels.

Option Explicit

Dim UserFile As String
'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

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

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 CopyMultipleFiles()
' This is the macro that the button on the 'Initialise' Sheet initiates


Dim lrow As Long
Dim i As Long
Dim r As Integer
Dim hyprng As String
Dim WB As Workbook
Dim WBr As Range
Dim WBlstrw As Long
Dim CurWks As Worksheet
Dim Msg As String
Dim Sht As Worksheet


On Error Resume Next

Msg = "Please select a Directory to Summarise."
UserFile = GetDirectory(Msg)
If UserFile = "" Then
MsgBox "Canceled"
ElseIf Not ContinueProcedure Then
Exit Sub
End If

Set CurWks = ActiveWorkbook.Worksheets("Summary&quot

Application.ScreenUpdating = False

lrow = 0
With Application.FileSearch
.SearchSubFolders = True
.NewSearch
.Filename = ".xls"
.LookIn = UserFile
.FileType = msoFileTypeExcelWorkbooks
.Execute
For i = 1 To .FoundFiles.Count
Set WB = Application.Workbooks.Open _
(Filename:=.FoundFiles(i))


WBlstrw = WB.Worksheets(1).Cells(Rows.Count, "A&quot.End(xlUp).Row


'Bring in the Data
CurWks.Cells(lrow + 3, "A&quot.Resize(WBlstrw, 6).Value = WB.Worksheets(1).Range("A1&quot.Resize(WBlstrw, 6).Value

'Bring in the filename
CurWks.Cells(lrow + 3, "H&quot.Resize(WBlstrw, 1).Value = WB.FullName

lrow = lrow + WBlstrw
WB.Close savechanges:=False
Next
End With


Set WB = Nothing
Set CurWks = Nothing

Application.ScreenUpdating = True


End Sub

Private Function ContinueProcedure() As Boolean
Dim Config As Integer
Dim Ans As Integer
Config = vbYesNo + vbQuestion + vbDefaultButton2
Ans = MsgBox(UserFile & &quot; <<< Is This The Correct Directory?&quot;, Config)
If Ans = vbYes Then
ContinueProcedure = True
Else: ContinueProcedure = False
End If

End Function

^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Copy Data above here into a single module in your workbook.


Then just hit the button and select the directory - Must be only Excel files in there. I can always send you the file if you prefer.

Regards
Ken....................

 

[gritz]

That's perfect! Thank you very much!

 

[KenWright]

Glad it worked for you. Looks complicated I know, but as you have seen, it is really just a case of copying and pasting the code into a module and you're away.

Regards
Ken.............