Subdirectory traverse and append to single file - II

thats too fast Rory, will give you a feedback in a few hours.

No worries. As you can see, that basically does a copy and paste operation so you will get exactly what was there before including formatting. If you just wanted to copy over the displayed values, you could use:

Sub ListSubFiles(strParentFolder As String)
    Dim fs As FileSearch
    Dim lngCounter As Long, lngRow As Long, lngOutputRow As Long
    Dim wbk As Workbook, wks1 As Worksheet, wks2 As Worksheet, wksSummary As Worksheet
    Dim rngData As Range, rngCell As Range
    Dim strCompany As String
    Application.ScreenUpdating = False
    Set wksSummary = ActiveWorkbook.ActiveSheet
    lngOutputRow = 1
    Set fs = Application.FileSearch
    With fs
        .NewSearch
        .LookIn = strParentFolder
        .SearchSubFolders = True
        .FileName = "*.xls"
        .MatchTextExactly = True
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        ' Loop through all the found files
        For lngCounter = 1 To .FoundFiles.Count
            Set wbk = Workbooks.Open(.FoundFiles(lngCounter))
            Set wks1 = wbk.Sheets("Detail sheet")
            Set wks2 = wbk.Sheets("Summary sheet")
            strCompany = wks2.Range("C3")
            ' Assumes there will always be data in column 1
            If lngCounter = 1 Then
                Set rngData = Intersect(wks1.UsedRange, wks1.Columns(1))
            Else
                Set rngData = Intersect(wks1.UsedRange, wks1.Range("A2:A65536"))
            End If
            For Each rngCell In rngData
                ' Write columns 1, 2 and 4 and company name to sheet 1 of this workbook
                wksSummary.Cells(lngOutputRow, 1) = rngCell.Text
                wksSummary.Cells(lngOutputRow, 2) = rngCell.Offset(0, 1).Text
                wksSummary.Cells(lngOutputRow, 3) = rngCell.Offset(0, 3).Text
                If lngOutputRow > 1 Then wksSummary.Cells(lngOutputRow, 4) = strCompany
                lngOutputRow = lngOutputRow + 1
            Next rngCell
            wbk.Close False
        Next lngCounter
        Set rngData = Nothing
        Set wks1 = Nothing
        Set wks2 = Nothing
        Set wbk = Nothing
    End With
    Set fs = Nothing
    Application.ScreenUpdating = True
End Sub

Regards,
Rory

The above doesnt work with the date field...
The data in the excel sheet is for example 24/09/1980 which is displayed as 24-Sep-1980 and whn it is copied to the new sheet using the macro it gets displayed as 29488 and if i  try to edit the cell it shoes the value of 24/09/1980 .
There is one more modificn which i require is that , there are two date fields and in one column i want to get the age in that.
For ex: Col E and Col F contain the dates 12/01/2001 and 25/06/2006 i want to get the difference in age in those columns.

Which version did you try? (Both?)
What exactly do you mean when you say you want the difference in age? Do you want the difference in days, or months, or something else?
Rory

I tried both.
but am sticking with the second one
wksSummary.Cells(lngOutputRow, 1) = rngCell.Text
wksSummary.Cells(lngOutputRow, 2) = rngCell.Offset(0, 1).Text
wksSummary.Cells(lngOutputRow, 3) = rngCell.Offset(0, 3).Text

or ex: Col E and Col F contain the dates 12/01/2001 and 25/06/2006
where Col E is the bithdate and Col F is the start date, i want to know the Age for that person as on the value in Col F.
so for ex in the above scenario it would be five (5) years

OK and where do you want it put?
I'm surprised the Copy version didn't work, since it should copy the whole cell including formatting. Are all the date fields in a specific place? If so, the code could simply format those columns at the end.
Regards,
Rory

"OK and where do you want it put?"
Lets say the last column .

"Are all the date fields in a specific place? If so, the code could simply format those columns at the end."
Are you asking whether the date field are in  specific columns ? If so, rite now they are in Column C,D and F.

Both versions of your code displays the date fields in excel serial number
24/09/1980 as 29488
04/04/1980 as 29315
and so on

 

Now I am confused - the code only looks at columns A, B and D so where do C and F come into it?
Regards,
Rory

Its just an example.
For the code sake, lets assume that the date fields are in B & D

OK then, try this:

Sub ListSubFiles(strParentFolder As String)
    Dim fs As FileSearch
    Dim lngCounter As Long, lngRow As Long, lngOutputRow As Long
    Dim wbk As Workbook, wks1 As Worksheet, wks2 As Worksheet, wksSummary As Worksheet
    Dim rngData As Range, rngCell As Range
    Dim strCompany As String
    Application.ScreenUpdating = False
    Set wksSummary = ActiveWorkbook.ActiveSheet
    lngOutputRow = 1
    Set fs = Application.FileSearch
    With fs
        .NewSearch
        .LookIn = strParentFolder
        .SearchSubFolders = True
        .FileName = "*.xls"
        .MatchTextExactly = True
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        ' Loop through all the found files
        For lngCounter = 1 To .FoundFiles.Count
            Set wbk = Workbooks.Open(.FoundFiles(lngCounter))
            Set wks1 = wbk.Sheets("Detail sheet")
            Set wks2 = wbk.Sheets("Summary sheet")
            strCompany = wks2.Range("C3")
            ' Assumes there will always be data in column 1
            If lngCounter = 1 Then
                Set rngData = Intersect(wks1.UsedRange, wks1.Columns(1))
            Else
                Set rngData = Intersect(wks1.UsedRange, wks1.Range("A2:A65536"))
            End If
            For Each rngCell In rngData
                ' Write columns 1, 2 and 4 and company name to sheet 1 of this workbook
                With wksSummary.Cells(lngOutputRow, 1)
                      .Value = rngCell
                      .Numberformat = "#,##0.00;-#,##0.00;0.00"
                End With
                With wksSummary.Cells(lngOutputRow, 2)
                      .Value = rngCell.Offset(0, 1)
                      .NumberFormat = "dd-mmm-yyyy"
                End With
                With wksSummary.Cells(lngOutputRow, 3)
                      .Value = rngCell.Offset(0, 3)
                      .NumberFormat = "dd-mmm-yyyy"
                End With
                If lngOutputRow > 1 Then
                     With wksSummary.Cells(lngOutputRow, 4)
                          .Value = strCompany
                          .Offset(0,1).FormulaR1C1 = "=Year(RC[-2])-year(RC[-3])-if(month(RC[-2])<month(RC[-3]),1,0)"
                          .Offset(0,1).NumberFormat = "0 ""years"""
                     End With
                End If
                lngOutputRow = lngOutputRow + 1
            Next rngCell
            wbk.Close False
        Next lngCounter
        Set rngData = Nothing
        Set wks1 = Nothing
        Set wks2 = Nothing
        Set wbk = Nothing
    End With
    Set fs = Nothing
    Application.ScreenUpdating = True
End Sub

Regards,
Rory

Still not working.
Please check the sample upload file that i have uploaded at
http://rapidshare.de/files/31310823/Sample.xls

The format is not as we are working on..but this is the actual data that we are trying to append.
All the columns that are shown are needed. ( There are more but i have deleted it )

Try this:

Sub ListSubFiles(strParentFolder As String)
    Dim fs As FileSearch
    Dim lngCounter As Long, lngRow As Long, lngOutputRow As Long
    Dim wbk As Workbook, wks1 As Worksheet, wks2 As Worksheet, wksSummary As Worksheet
    Dim rngData As Range, rngCell As Range
    Dim strCompany As String
    Application.ScreenUpdating = False
    Set wksSummary = ActiveWorkbook.ActiveSheet
    lngOutputRow = 1
    Set fs = Application.FileSearch
    With fs
        .NewSearch
        .LookIn = strParentFolder
        .SearchSubFolders = True
        .FileName = "*.xls"
        .MatchTextExactly = True
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        ' Loop through all the found files
        For lngCounter = 1 To .FoundFiles.Count
            Set wbk = Workbooks.Open(.FoundFiles(lngCounter))
            Set wks1 = wbk.Sheets("Detail sheet")
            Set wks2 = wbk.Sheets("Summary sheet")
            strCompany = wks2.Range("C3")
            ' Assumes there will always be data in column 1
            If lngCounter = 1 Then
                Set rngData = Intersect(wks1.UsedRange, wks1.Range("A3:A65536"))
            Else
                Set rngData = Intersect(wks1.UsedRange, wks1.Range("A4:A65536"))
            End If
            For Each rngCell In rngData
                ' Write columns 1, 2 and 4 and company name to sheet 1 of this workbook
                If Len(rngCell) > 0 Then
                    With wksSummary.Cells(lngOutputRow, 1)
                          .Value = rngCell
                          .NumberFormat = "#,##0.00;-#,##0.00;0.00"
                    End With
                    With wksSummary.Cells(lngOutputRow, 2)
                          .Value = rngCell.Offset(0, 1)
                          .NumberFormat = "dd-mmm-yyyy"
                    End With
                    With wksSummary.Cells(lngOutputRow, 3)
                          .Value = rngCell.Offset(0, 3)
                          .NumberFormat = "dd-mmm-yyyy"
                    End With
                    If lngOutputRow > 1 Then
                         With wksSummary.Cells(lngOutputRow, 4)
                              .Value = strCompany
                              .Offset(0, 1).Value = DatePart("yyyy", rngCell.Offset(0, 3)) - DatePart("yyyy", rngCell.Offset(0, 2)) - IIf(DatePart("m", rngCell.Offset(0, 3)) < DatePart("m", rngCell.Offset(0, 2)), 1, 0)
                              .Offset(0, 1).NumberFormat = "0 ""years"""
                         End With
                    End If
                    lngOutputRow = lngOutputRow + 1
                End If
            Next rngCell
            wbk.Close False
        Next lngCounter
        Set rngData = Nothing
        Set wks1 = Nothing
        Set wks2 = Nothing
        Set wbk = Nothing
    End With
    Set fs = Nothing
    Application.ScreenUpdating = True
End Sub


Regards,
Rory

PS "Not working" is not that useful - if you can tell me in what way it is failing that will speed things up!

"PS "Not working" is not that useful - if you can tell me in what way it is failing that will speed things up!"

Rory, i am still stuck with the one and the same problem , the dates are not displayed properly. So i didnt mention it again. Sorry.

Still no change . The dates dont appear in the date format and are appearing as numbers

Emp No      Emp Name      DOJ            
40      B O B                   38777      ( if i click on the DOJ row cell it shows the value 3/1/2006 )
03      C O D                  38824      ( here it shows the value 4/17/2006)
14      D J                    38831      (4/24/2006)

Well, I confess I'm stumped - I tested that several times on the sample file you provided and it *always* formatted the dates. However, I note your comment: "The format is not as we are working on..but this is the actual data that we are trying to append." Does this mean you are amending the code to fit the actual format you are working on?
Regards,
Rory

What i meant is i have not given the whole data which spans 20-30 columns. The format is the same.

"Does this mean you are amending the code to fit the actual format you are working on?"
We are adding the number of cells and thats it. The dateformat is as in the uploaded file.


We are working with excel 2002. Would that make any difference ?

I am using XL2002 as well.
The only thing I can think of right now is that there may be something about the worksheet you are copying to - is this a blank new workbook or a pre-existing one?
Regards,
Rory

I created a new excel file
COpied the above macro into it.
And ran it from there.
So its a blank new workbook.
I am okay with testing it by copying it to a new excel file if you think that might make a difference and as long as you supply the code for it :-)

If you ran it already from a new blank workbook then that shouldn't be the problem. Any chance that you could post a copy of the workbook you have run it from (where it didn't work), including the code, and a full sample of the dataset it runs against - you can reduce the number of rows, but please keep all the columns? That way I can just double-check that I haven't missed anything obvious!
Regards,
Rory

Check http://rapidshare.de/files/31410737/Tosend.zip.html

Got it working. I made active another worksheet and it executed properly.
Let me just do some more runs and i will close this question soon.

Sounds promising! Fingers crossed...
Rory

One problem in getting the age ( date difference)
The dates are displayed as 24-Sep-80 and 01-Mar-06
so when i use the code
wksSummary.Cells(lngOutputRow, 10) = DatePart("yy", rngCell.Offset(0, 8)) - DatePart("yy", rngCell.Offset(0, 3)) - IIf(DatePart("m", rngCell.Offset(0, 8)) < DatePart("m", rngCell.Offset(0, 3)), 1, 0)
i get a Type mismatch error. ( the values that they get are the proper date fields i confirmed that )
The dates are in the columns C and H.
So i want to paste the difference between the too in column J .

"yy" is not a valid argument for the DatePart function - you need to use "yyyy". You may also need to doublecheck that all the cells in question contain valid dates - if any are blank, you would get that error.
Regards,
Rory

it was yyyy, since the date is dipslayed as 24-Sep-80 , i used yy.
no dates are blank . i checked with only three records

I just noticed you said the dates are in C and H - the offsets you are using are 3 and 8, which actually gives you columns D and I, since 3 to the right from column 1 is actually column 4 not column 3 and similarly for the 8. Try changing the offsets to 2 and 7.
HTH
Rory

Doh! This is breaking me up.
sorry.

no problem - been there, done that! :-)
Rory

thanks that works.
Would it be possible to have the output to be copied to another file instead of having it be appended where the macro is run ?

Do you want it to be a new file, or a specified file?
Regards,
Rory

PS As it is currently, the code outputs the data to whatever is the activesheet when you run the macro. So you can just open a new workbook and run the code.
Rory

"the code outputs the data to whatever is the activesheet when you run the macro"
 i would like it to o/p in a new file.

Change this line (near the top):
    Set wksSummary = ActiveWorkbook.ActiveSheet

to this:
    Set wksSummary = Workbooks.Add.Sheets(1)

HTH
Rory

'Set wksSummary = Workbooks.Add.Sheets(1)
I was talking about a new excel file and not a new excel sheet.
Say if i run this from macro.xls it should ask for and save it in a file say userprefernce.xls.
Would that be possible ?