Append Data from multiple excel files to one excel file

[rocksolidsr]

I'm trying to parse multiple excel files in multiple sub-directories and I'm only looking for a few cells in one row of the excel files, once I find the cells I would like to be able to copy them and paste them into an excel file that keeps all the data. I have the following code that does it for just one file

The reason for this, is because every time a test is ran one of these excel files is created for each test, but I would like all the relevant data in one file for better statistical data analysis.

The cells I want to extract are B28, C28, D28, E28, F28, G28

Option Explicit

Dim objExcel, strExcelPath, objSheet, intRow, serialnumber, res_freq
Dim anti_res_freq, freq_diff, i_at_res, r_at_res, objExcel2, strNewFile, objSheet2 

' Bind to Excel object.
On Error Resume Next
Set objExcel = CreateObject("Excel.Application")
If (Err.Number <> 0) Then
    On Error GoTo 0
    Wscript.Echo "Excel application not found."
    Wscript.Quit
End If
On Error GoTo 0

'Need to read all excel files in all subdirectories
strExcelPath = "C:\Documents and Settings\srock\Desktop\Excel Scripts\Imp_Test_Data_2009_Realibility Test 1.xls"

' Open specified spreadsheet and select the first worksheet.
objExcel.WorkBooks.Open strExcelPath
Set objSheet = objExcel.ActiveWorkbook.Worksheets(1)

' Iterate through the rows of the spreadsheet after the first, until the
' first blank entry in the first column. For each row, bind to the user
' specified in the first column and set attributes.
intRow = 28
Do While objSheet.Cells(intRow, 1).Value <> ""
    serialnumber = objSheet.Cells(intRow, 2).Value
    res_freq = objSheet.Cells(intRow, 3).Value
    anti_res_freq = objSheet.Cells(intRow, 4).Value
    freq_diff = objSheet.Cells(intRow, 5).Value
	i_at_res = objSheet.Cells(intRow, 6).Value
	r_at_res = objSheet.Cells(intRow, 7).Value
    On Error Resume Next
    intRow = intRow + 1
Loop

'Create New File with appended data
strNewFile = "C:\Documents and Settings\srock\Desktop\Excel Scripts\UserGroup.xls"

' Bind to Excel object.
On Error Resume Next
Set objExcel2 = CreateObject("Excel.Application")
If (Err.Number <> 0) Then
    On Error GoTo 0
    Wscript.Echo "Excel application not found."
    Wscript.Quit
End If
On Error GoTo 0

' Create a new workbook.
objExcel2.Workbooks.Add


Set objSheet2 = objExcel2.ActiveWorkbook.Worksheets(1)
objSheet2.Name = "User Groups"

' Populate spreadsheet cells with user attributes.
objSheet2.Cells(2, 1).Value = serialnumber
objSheet2.Cells(2, 2).Value = res_freq
objSheet2.Cells(2, 3).Value = anti_res_freq
objSheet2.Cells(2, 4).Value = freq_diff
objSheet2.Cells(2, 5).Value = i_at_res
objSheet2.Cells(2, 6).Value = r_at_res

' Save the spreadsheet and close the workbook.
objExcel2.ActiveWorkbook.SaveAs strNewFile
objExcel2.ActiveWorkbook.Close

' Quit Excel.
objExcel2.Application.Quit

' Close workbook and quit Excel.
objExcel.ActiveWorkbook.Close
objExcel.Application.Quit

' Clean up.
Set objExcel = Nothing
Set objSheet = Nothing
'Set objUser = Nothing

Wscript.Echo "Done"

I've attached the excel spreadsheet that I will be parsing.

any help would be appreciated. thanks.

 

[mrmovie]

get them to update the process which creates the excel files saves you the bother?

have a look at the FQA with recursive folder function..

 

[rocksolidsr]

the process cannot be updated it comes from a labview program which the source code no long exists

 

[mrmovie]

'was posted as a FAQ, not to great a'plum, lord knows what is wrong with some people


strDir = "f:\"
Set objDir = FSO.GetFolder(strDir)
getInfo(objDir)

Sub getInfo(pCurrentDir)

For Each aItem In pCurrentDir.Files
'wscript.Echo aItem.Name
If LCase(Right(Cstr(aItem.Name), 3)) = "xls" Then
'do file manip, copy delete here
Call Your Sub or FUnction here to read the excel doc
End If
Next

For Each aItem In pCurrentDir.SubFolders
'wscript.Echo aItem.Name & " passing recursively"
getInfo(aItem)
Next

End Sub