Okay, well this was developed in Excel 2003. The code is rather long, but it works splendidly for me. I hope it's what you were asking for. There is a couple issues that needs pointing out..
365 days per year (sheets)
{variable}49 rows of info per day (sheet)
3 years of data
2 data locations
.. that roughly equals 107310 rows of information. Obviously that is too much for one sheet to handle (given that you are using Excel 2003 or prior, 2007 can handle this without any qualms but the code would need to be adjusted to accept the different file types/extensions), so there is a section of code written that will add a new sheet for any overflow data. When I ran this code on your files I was left with two sheets of data.
The other issue is that there is a reference set to
Microsoft Scritping Runtime (via VBE \ Tools \ References). I have this code in a sample file and linked to it, the reference is already set there. I ran the code in this file as well, and the first two sheets contain the data from the files you uploaded.
Here is a link to the file:
http://www.barresse.com/temp/MyDataExtraction_Ex.zipHere is the code (which goes in a standard module)..
Code:
Option Explicit'Set folder name to iterate through'THIS MUST BE ACCURATE!Private Const FOLDERNAME As String = "C:\Documents and Settings\Administrator.ZACKOLD\Desktop\MyFolder\"Private Const DNL As String = vbNewLine & vbNewLineSub ExtractData()'Created by: Zack Barresse'Date: September 2006'Purpose: Iterate through set folder and extract data from each' worksheet of each workbook found and compile it into a' single workbook for analysis. Code is self-sustained' and tested in a Windows XP Pro OS with Office 2003' Professional SP2.'References: Microsoft Scripting Runtime Dim FSO As Scripting.FileSystemObject Dim fsoFolder As Scripting.Folder Dim fsoFile As Scripting.File Dim wb As Workbook, wbTmp As Workbook Dim ws As Worksheet, wsTmp As Worksheet Dim rngCopy As Range, rngDate As Range Dim iCnt As Long, iWs As Long Dim eRow As Long, sRow As Long Dim LastRow As Long, i As Long Dim strPrompt As String, strTitle As String Dim blnDelete As Boolean, blnClose As Boolean Dim Msg As VbMsgBoxResult, msgDel As VbMsgBoxResult 'Set error handler status On Error GoTo ErrHandler 'Turn off application attributes Call ToggleEvents(False) 'Set objects, folder (create if none) & variables Set wb = ThisWorkbook Set FSO = New Scripting.FileSystemObject If FSO.FolderExists(FOLDERNAME) Then Set fsoFolder = FSO.GetFolder(FOLDERNAME) Else FSO.CreateFolder (FOLDERNAME) strPrompt = "The spcified folder does not exist!" & DNL strPrompt = strPrompt & "Do you wish to create it now?" strTitle = "Create Folder?" Msg = MsgBox(strPrompt, vbYesNo, strTitle) If Msg = vbYes Then Set fsoFolder = FSO.GetFolder(FOLDERNAME) MsgBox "Folder created!" & DNL & "Exiting application!", vbInformation GoTo TheEnd Else MsgBox "No folder created!" & DNL & "Exiting application!", vbInformation GoTo TheEnd End If End If 'Check for files If fsoFolder.Files.Count = 0 Then MsgBox "There are no files to process!", vbInformation, "ERROR!" GoTo TheEnd Else 'If files found, ask if user wants to delete them after processing blnDelete = False strPrompt = "Would you like to delete the files when done" & vbNewLine strPrompt = strPrompt & "processing them?" strTitle = "Delete Files After Processing?" msgDel = MsgBox(strPrompt, vbYesNo, strTitle) If msgDel = vbYes Then blnDelete = True End If End If 'Ensure a blank sheet is ready, set as variable Set ws = wb.Worksheets.Add(Before:=wb.Sheets(1)) 'Set headings for file import ws.Range("A1").Value = "Date" ws.Range("B1").Value = "Time" ws.Range("C1").Value = "Temperature" ws.Range("D1").Value = "Humidity" 'Iterate through files in folder For Each fsoFile In fsoFolder.Files 'Check for Excel files only (ver 2003 and prior) If LCase(Right(fsoFile.Name, 4)) <> ".xls" Then GoTo SkipFile 'Check if file is open, set to variable If WbOpen(fsoFile.Name) = True Then Set wbTmp = Workbooks(fsoFile.Name) blnClose = False Else Set wbTmp = Workbooks.Open(FOLDERNAME & fsoFile.Name) blnClose = True End If 'Reset sheet counter & variables, add file counter iWs = 0 iCnt = iCnt + 1 Set rngCopy = Nothing 'Iterate through all sheets in file For Each wsTmp In wbTmp.Worksheets 'Worksheet counter, also our row counter, and the end row iWs = iWs + 1 eRow = wsTmp.Cells(wsTmp.Rows.Count, 2).End(xlUp).Row 'Check if there is room for more data LastRow = ws.Range("A:A").Find(what:="*", After:=ws.Cells(1, 1), _ searchorder:=xlByRows, _ searchdirection:=xlPrevious).Row 'If there is no more room, fit data and create a new sheet If LastRow + eRow > ws.Rows.Count Then ws.Cells.EntireColumn.AutoFit 'Add new worksheet and headings if this is the case Set ws = wb.Worksheets.Add(After:=wb.Sheets(1)) ws.Range("A1").Value = "Date" ws.Range("B1").Value = "Time" ws.Range("C1").Value = "Temperature" ws.Range("D1").Value = "Humidity" End If sRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1 'Inform user of progress on status bar Application.StatusBar = "Processing sheet " & iWs & " of " & _ wbTmp.Worksheets.Count & ", in file " & _ iCnt & " of " & fsoFolder.Files.Count & _ " total file(s)..." 'Copy data to worksheet Set rngCopy = wsTmp.Range("A3:A" & eRow) i = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row + 1 rngCopy.Offset(0, 0).Copy ws.Cells(i, 2) rngCopy.Offset(0, 1).Copy ws.Cells(i, 3) rngCopy.Offset(0, 3).Copy ws.Cells(i, 4) 'Add date to time value in column A and make it static and format it LastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row Set rngDate = ws.Range(ws.Cells(sRow, 1), ws.Cells(LastRow, 1)) rngDate.Value = CDate(wsTmp.Name)' rngDate.FormulaR1C1 = "=" & Chr(34) & CDate(wsTmp.Name) & Chr(34) & "+RC[1]"' rngDate.Value = rngDate.Value rngDate.NumberFormat = "dd-mm-yyyy hh:mm AM/PM" Next wsTmp 'If user wanted to delete file, do it here If blnDelete = True Then fsoFile.Delete Force:=True End If If blnClose = True Then wbTmp.Close SaveChanges:=False End IfSkipFile: Next fsoFile 'Fit all columns and report to user the completion status If iCnt > 0 Then ws.Cells.EntireColumn.AutoFit strPrompt = "There were a total of " & iCnt & " file(s) processed." MsgBox strPrompt, vbInformation, "Completed!" End IfTheEnd: 'Reset application attributes Call ToggleEvents(True) Exit SubErrHandler: strPrompt = "An unexpected error has occured!" strPrompt = strPrompt & DNL & Err.Description MsgBox strPrompt, vbCritical, "ERROR!" Resume TheEndEnd SubSub ToggleEvents(blnState As Boolean)'Created by: Zack Barresse'Date: September 2006'Purpose: Toggle application properties for code efficiency purposes. With Application .DisplayAlerts = blnState .EnableEvents = blnState .ScreenUpdating = blnState If blnState = True Then .CutCopyMode = False .StatusBar = False End If End WithEnd SubFunction WbOpen(wbName As String) As Boolean'Created by: Zack Barresse'Date: September 2006'Purpose: Check if a specified workbook is already open or not. On Error Resume Next WbOpen = CBool(Len(Workbooks(wbName).Name))End Function
Let me know how it goes. I spent a considerable amount of time on it and would love to know if it works for you or not.