Open all files in a directory and merge to one file

[chrisweirman]

Hi, I received some help earlier and got a program to interrogate 25 sheets in a workbook finding local maximum values working an outputting onto the first sheet.

To make my life very much easier would it be possible to add some code to the vba program that is working to get it to open all the files in a directory and find the data?

The only problem seems to be that the files are not excel files but .grd files. I normally open them using a space delimited import. I've found some help on workbook.opentext use together with a piece of code that opens all files from a directory but I get an 'object not supported' error? (I'm running ms office 2007)

My current evolution of the code is;

Sub findmax()
Dim MyDir As String
Dim strPath As String
Dim vaFileName As Variant
Dim v As Integer
Dim c As Range
Dim i As Long
Dim shtcnt As Long

i = 10
MyDir = ActiveWorkbook.Path ' current path
strPath = MyDir & "\residual files\" ' files subdir
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.Filename = ".grd"
If .Execute > 0 Then
For Each vaFileName In .FoundFiles
Workbooks.OpenText Filename:=vaFileName, Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=True, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), _
Array(9, 1), Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15 _
, 1), Array(16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), _
Array(22, 1), Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array( _
28, 1), Array(29, 1), Array(30, 1), Array(31, 1), Array(32, 1), Array(33, 1), Array(34, 1), _
Array(35, 1)), TrailingMinusNumbers:=True
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
With ActiveWorkbook
Sheets(0).Move after:=Workbooks("book4").Sheets(1)
For Each c In ActiveSheet.Range("b6:at91")
If c.Value > 0 And c.Value >= c.Offset(-1, -1).Value And c.Value >= c.Offset(-1, 0).Value And c.Value >= c.Offset(-1, 1).Value And c.Value >= c.Offset(0, -1).Value And c.Value >= c.Offset(0, 1).Value And c.Value >= c.Offset(1, -1).Value And c.Value >= c.Offset(1, 0).Value And c.Value >= c.Offset(1, 1).Value Then
Worksheets("residuals").Range("a" & i) = ActiveSheet.Name
Worksheets("residuals").Range("b" & i) = c.Value
Worksheets("residuals").Range("c" & i).Formula = "=address(" & c.row & "," & c.column & ")"
i = i + 1
End If
Next c
End With
Next
Else: End If
End With
End Sub

Can anybody see where I've gone wrong?? (probably the start eh...)

[chrisweirman]

I've just checked my vb version and it's 6.5 don't know if that why it's not working, the error I get is "Object doesn't support this action"

[Kenneth Hobs]

Always use this as the first line of your vba code:
Option Explicit
2007 does not support FileSearch.

See this thread for some alternatives: http://www.vbaexpress.com/forum/showthread.php?t=22245
This thread uses a class similar to the FileSearch method: http://www.mrexcel.com/forum/showthread.php?t=369982

[chrisweirman]

will vba open all files in a directory with something like workbook.open text inside a with all statement??

[chrisweirman]

operation explicit code line returns an error of invalid outside procedure. I have put in as the first line of code...i have seen other examples of operation explicit use - do you think it's my version or something?

[Kenneth Hobs]

Option Explicit
Sub Test
MsgBox "Hello World!"
End Sub

Not sure what you mean by:
like workbook.open text inside a with all statement?

The methods that I pointed out return an array of filenames. What you do from there is a simple matter. The meat is in the details of course.

[chrisweirman]

hi, I've read up about operation explicit and I've moved my code to the module page, entered operation explicit as the first line and it still returns an 'invalid outside procedure' error on compiling, when it is inside a sub it returns 'sub or function not defined'. I'm sorry I don't understand why.

What I mean by using a workbook.open statement inside a with-all statement is, in the code below

Sub findmax_with_file_open()
Dim c As Range
Dim i As Long
Dim shtcnt As Long
Dim column As Integer
column = -4
Dim threshold_value As Long
threshold_value = 0.1
'If msgbox("Residuals threshold value set to 0.1. Do you want to change this?", vbYesNo + vbDefaultButton2, "Threshold Value OK?") = vbYes Then
'threshold_value = Application.InputBox("Please input new threshold value", "Threshold Value Input", 0.1, , , , , 1)
'Else: End If

For Each s In ActiveWorkbook.Sheets
s.Activate
If s.Name <> "residuals" Then
i = 10
For Each c In Worksheets(s.Name).Range("b6:at91")
If c.Value > 0.1 Then
If c.Value > c.Offset(-1, -1).Value And c.Value > c.Offset(-1, 0).Value And c.Value > c.Offset(-1, 1).Value And c.Value > c.Offset(0, -1).Value And c.Value > c.Offset(0, 1).Value And c.Value > c.Offset(1, -1).Value And c.Value > c.Offset(1, 0).Value And c.Value >= c.Offset(1, 1).Value Then
With c.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Worksheets("residuals").Cells(i, column) = "Scan " & ActiveSheet.Name
Worksheets("residuals").Cells(i, column + 1) = "Anode " & i - 9
Worksheets("residuals").Cells(i, column + 2) = c.Value
Worksheets("residuals").Cells(i, column + 3).Formula = "=address(" & c.row & "," & c.column & ")"
i = i + 1
End If
End If
Next c
End If
column = column + 5
Next s
Worksheets("residuals").Activate
End Sub

I've got a for each statement. Can this type of statement be used in something like

for each w in workbook.path
workbook.opentext ...
above code
next w

:dunno

[Kenneth Hobs]

Just copy and paste my code to test. As you can see, you used "operation explicit" where you should have used "Option Explicit". As I explained, in the VBE you can do Tools > Options... > Editor > and check the Require Variable Declaration > OK.

Workbook.path means nothing. Even if you did ThisWorkbook.Path, that would just return that workbook's path. Type For or Each in VBE and press F1. You will see that you need to specify a group in the For Each loop which is a collection or an array.

The links that I provided can put the filenames into an array.

Opening each file in Excel may not be the best route. You can use File reading methods or even an ADO method to get what you need if your data is in some format like csv. You can post a few sample files if needed. We would need to know what you need from them.

[chrisweirman]

thanks Ken, though would you be able to explain how I set up an array for filenames, there are 25 files in a sub-directory where the macro file is stored, hence why i've been trying to use activeworkbook.path in a string building line of code to add on "\residual files\" to the path to locate the files for import. I've used record macro to show code that will import one of the files (called ...000calib.txt) and then modify with a loop to change the file string using something like "...00" & x & "calib.txt" where x goes from 0 to 24. haven't got it to work and it sounds like it wont with your advice. ideas?

[Kenneth Hobs]

If you know the path to the folder and don't need subfolders searched, a Dir() loop will suffice. However, all of the methods that I gave will do it as well. You just tell it not to search subfolders.

For the Dir() method, the returned array contains just the filenames. You need to add their folder for your interative loop. Test this in a blank sheet. Put the code in a Module and play the Sub Test.
e.g.

Sub test()
Dim p As String, x As Variant, i As Integer

'p = "c:/msoffice/excel/library/*.xls"
p = ThisWorkbook.Path & "\residual files\*calib.txt"
x = GetFileList(p)
Select Case IsArray(x)
Case True 'files found
MsgBox UBound(x)
Sheets("Sheet1").Range("A:A").Clear
For i = LBound(x) To UBound(x)
Sheets("Sheet1").Cells(i, 1).Value = x(i)
Next i
Case False 'no files found
MsgBox "No matching files"
End Select
End Sub

'http://spreadsheetpage.com/index.php/tip/getting_a_list_of_file_names_using_vba/
Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False

Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String

On Error GoTo NoFilesFound

FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound

' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function

' Error handler
NoFilesFound:
GetFileList = False
End Function

[chrisweirman]

Hi Ken, thanks for your help. I was working on this until late last night and found a coding that works. It's nowhere near as elegant as yours but it works ok.

Here's how I did it;

Sub import_files_into_workbook()
'
' import_file_into_workbook Macro
'
Dim myfile As String
Dim mypath As String
Dim this_file As String
Dim target_file As String
Dim f As Integer
Dim scan_data As Variant
this_file = ActiveSheet.Name
mypath = ActiveWorkbook.Path & "\"
For f = 1 To 25
If f <= 10 Then
myfile = "text;" & mypath & this_file & "00" & (f - 1) & "calib.grd"
target_file = this_file & "00" & (f - 1) & "calib"
End If
If f > 10 Then
myfile = "text;" & mypath & this_file & "0" & (f - 1) & "calib.grd"
target_file = this_file & "0" & (f - 1) & "calib"
End If
'
ActiveWorkbook.Worksheets.Add
With ActiveSheet.QueryTables.Add(Connection:= _
myfile _
, Destination:=Range("$B$1"))
.Name = target_file
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Sheets.Select
Sheets(f).Move After:=Sheets(f + 1)
'Columns("b:b").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveSheet.Name = target_file
'select range of cells
'If f = 1 Then
'Set scan_data = Application.InputBox("Please select cell range", "Cell Range Selection", "B6:AT91", , , , , 8)
'last_cell = Range.Find(8, "b6")
'End If
Next f
Dim c As Range
Dim i As Long
Dim shtcnt As Long
Dim column As Integer
Dim s As Variant
column = 0
Dim threshold_value As Long
If MsgBox("Residuals threshold value set to 0.1. Do you want to change this?", vbYesNo + vbDefaultButton2, "Threshold Value OK?") = vbYes Then
threshold_value = Application.InputBox("Please input new threshold value", "Threshold Value Input", 0.1, , , , , 1)
Else: threshold_value = 0.1
End If
For Each s In ActiveWorkbook.Sheets
s.Activate
'If column = 1 Then
' scan_data = Application.InputBox("Please select cell range", "Cell Range Selection", "B6:AT91", , , , , 8)
'End If
If s.Name <> this_file Then
i = 10
Worksheets(this_file).Cells(i, column + 2) = ActiveSheet.Name
i = i + 1
For Each c In Worksheets(s.Name).Range("b6:bz200")
If c.Value > threshold_value And c.Value > c.Offset(-1, -1).Value And c.Value > c.Offset(-1, 0).Value And c.Value > c.Offset(-1, 1).Value And c.Value > c.Offset(0, -1).Value And c.Value > c.Offset(0, 1).Value And c.Value > c.Offset(1, -1).Value And c.Value > c.Offset(1, 0).Value And c.Value >= c.Offset(1, 1).Value Then
With c.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Worksheets(this_file).Cells(i, column) = ActiveSheet.Name
If column = 1 Then
Worksheets(this_file).Cells(i, column) = "Anode " & i - 9
Worksheets(this_file).Cells(i, column + 1).Formula = "=address(" & c.row & "," & c.column & ")"
Else: End If
Worksheets(this_file).Cells(i, column + 2) = c.Value
i = i + 1
Else
i = i + 1
End If
Next c
End If
column = column + 1
Next s
Worksheets(this_file).Activate
Cells.Select
Cells.EntireColumn.AutoFit
Cells.Select
Selection.Copy
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Replace What:="$", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'For Each c In Worksheets(this_file).Range("a10:dt20000")
'Next c
Rows("11:6557").Select
ActiveWorkbook.Worksheets(this_file).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(this_file).Sort.SortFields.Add Key:= _
Range("A11"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets(this_file).Sort
.SetRange Range("A11:DS6557")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub

I'm now tring to manipulate the data it's returning to get something more like what I'm after.

Cheers