Copy in Single Sheet

[narendra1302]

Dear All,

I have 28 excel files having various sheets in it ranging from 1 to 25 sheets in a file.
The first row contains HEADER - Which is common in all the files & sheets.

Now I want a single sheet which will contain all the data of all 28 files.

I am using Excel 2007.

Thanks
Narendra

 

[narendra1302]

Hi,

Is there any solution of this problem ?

Thanks
Narendra

 

[GTO]

Hi there,

I think a tad more detail might help. You mention that the header is common amongst all sheets/files. Does this mean that all sheets have all the same info in the same columns (?) and thus, we are just appending each sheets data to the destination sheet, and doing this for all files?

 

[narendra1302]

Thanks GTO for your reply.

Yes - All the sheets have same infor in the same columns. We just have to append it.

Thanks
Narendra

 

[narendra1302]

Hi All,

Is there any updated ?

Thanks
Narendra

 

[GTO]

Hi Narenda,

You posted your initial question, bumped an hour later, and less than an hour after answering my question, seem to be asking "where's my code?". Really? This is a great site because of many great folks who share their knowledge freely and are most helpful. It ain't "free coders r us".

Here is what I wacked together. A bit rough, but I believe it will get you near your goal. Hope it helps.

This presumes the wb with the code is in the same folder as the wb's with teh data.

Option Explicit
    
Sub exa()
Dim _
wksDestination          As Worksheet, _
wks                     As Worksheet, _
wbSource                As Workbook, _
aryTmp                  As Variant, _
rngLRow                 As Range, _
rngLCol                 As Range, _
rngLCell                As Range, _
rngData                 As Range, _
rngDest                 As Range, _
FSO                     As Object, _
fsoFolder               As Object, _
fsoFile                 As Object
        
    Application.ScreenUpdating = False
    Set wksDestination = ThisWorkbook.Worksheets("Destination")
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fsoFolder = FSO.GetFolder(ThisWorkbook.Path)
    
    For Each fsoFile In fsoFolder.Files
        If fsoFile.Path <> ThisWorkbook.FullName _
        And Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".")) = ".xls" Then
        
            Set wbSource = Workbooks.Open(fsoFile.Path, , True)
            For Each wks In wbSource.Worksheets
                Set rngLRow = RangeFound(SearchRange:=Range(wks.Cells(2, 1), _
                                                            wks.Cells(wks.Rows.Count, wks.Columns.Count)) _
                                         )
                
                If Not rngLRow Is Nothing Then
                    Set rngLCol = _
                        RangeFound(SearchRange:=Range(wks.Cells(2, 1), _
                                                       wks.Cells(wks.Rows.Count, wks.Columns.Count)), _
                                   SearchRowCol:=xlByColumns)
                                   
                    Set rngLCell = Application.Intersect(wks.Rows(rngLRow.Row), wks.Columns(rngLCol.Column))
                    
                    aryTmp = Range(wks.Cells(2, 1), rngLCell).Value2
                    
                    With wksDestination
                        Set rngDest = RangeFound(Range(.Cells(2, 1), .Cells(.Rows.Count, .Columns.Count)))
                    End With
                    
                    If rngDest Is Nothing Then
                        Set rngDest = wksDestination.Cells(2, 1)
                    Else
                        Set rngDest = wksDestination.Cells(rngDest.Row + 1, 1)
                    End If
                    
                    If Not UBound(aryTmp, 1) + rngDest.Row > rngDest.Parent.Rows.Count Then
                        rngDest.Resize(UBound(aryTmp, 1), UBound(aryTmp, 2)).Value = aryTmp
                    Else
                        MsgBox "Sorry, sheet is full", vbInformation, vbNullString
                        wbSource.Close False
                        Application.ScreenUpdating = True
                        Exit Sub
                    End If
                End If
            Next
            wbSource.Close False
        End If
    Next
    
    Application.ScreenUpdating = True
End Sub
    
Function RangeFound(SearchRange As Range, _
                    Optional FindWhat As String = "*", _
                    Optional StartingAfter As Range, _
                    Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
                    Optional LookAtWholeOrPart As XlLookAt = xlPart, _
                    Optional SearchRowCol As XlSearchOrder = xlByRows, _
                    Optional SearchUpDn As XlSearchDirection = xlPrevious, _
                    Optional bMatchCase As Boolean = False) As Range
    
    If StartingAfter Is Nothing Then
        Set StartingAfter = SearchRange(1)
    End If
    
    Set RangeFound = SearchRange.Find(What:=FindWhat, _
                                      After:=StartingAfter, _
                                      LookIn:=LookAtTextOrFormula, _
                                      LookAt:=LookAtWholeOrPart, _
                                      SearchOrder:=SearchRowCol, _
                                      SearchDirection:=SearchUpDn, _
                                      MatchCase:=bMatchCase)
End Function

 

[narendra1302]

Thanks GTO,

Working fine.

Thanks
Narendra