Copying Data from Specific Sheet of a Multiple Workbooks to Specific Sheet of a One Workbook

[madhuchelliah]

Hello Folks, i need to copy datas from a specific sheet(Summary) of multiple workbooks in a folder to a specific sheet(Summary) of the parent workbook. I will run the macro from the parent file. I tried by best, it is beyond my basic knowledge. I leave it to you guys.
My inputs:
1. Sheets name is including parent workbook - Summary.
2. Copying Range from children workbook is from columns D5:I5 to rows used range.(pasting should be stacked after each sheets data.)
3. All the children files are in the Children folder which is under the parent workbook folder.
The data of all the workbook should be pasted continuously without any gap.
When the pasting of the each workbook starts, the name of the workbook should be offset to C column cell. For example if the paste start cell in the parent workbook will be always D5 so the pasted workbook name should be displayed in C5, like that if the next workbook paste starts in D10 then workbook name should be in C10. Please heads up. Thank you.

 

[mumps]

This macro assumes that the destination workbook is in the same folder as the source workbooks. It also assumes that the source files all have an "xlsx" extension and that these files are the only files in your folder. Copy/paste the macro in a regular module in your destination workbook and save the workbook as a macro-enabled file before you run the macro.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    'Dim x As Long: x = 5
    Dim desWS As Worksheet
    Set desWS = ActiveWorkbook.Sheets("Summary")
    Dim srcWB As Workbook
    Dim srcWS As Worksheet
    Dim fileName As String
    fileName = Dir(strPath & "*.xlsx")
    Do While fileName <> ""
        Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\" & fileName)
        Set srcWS = srcWB.Sheets("Summary")
        With srcWS
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            srcWS.Range("C5:C" & LastRow) = srcWB.Name
            If desWS.Range("C" & desWS.Rows.Count).End(xlUp).Row < 5 Then
                .Range("C5:I" & LastRow).Copy desWS.Range("C5")
            Else
                .Range("C5:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Offset(1, 0)
            End If
            srcWB.Close savechanges:=False
        End With
        fileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[madhuchelliah]

This macro assumes that the destination workbook is in the same folder as the source workbooks. It also assumes that the source files all have an "xlsx" extension and that these files are the only files in your folder. Copy/paste the macro in a regular module in your destination workbook and save the workbook as a macro-enabled file before you run the macro.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    'Dim x As Long: x = 5
    Dim desWS As Worksheet
    Set desWS = ActiveWorkbook.Sheets("Summary")
    Dim srcWB As Workbook
    Dim srcWS As Worksheet
    Dim fileName As String
    fileName = Dir(strPath & "*.xlsx")
    Do While fileName <> ""
        Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\" & fileName)
        Set srcWS = srcWB.Sheets("Summary")
        With srcWS
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            srcWS.Range("C5:C" & LastRow) = srcWB.Name
            If desWS.Range("C" & desWS.Rows.Count).End(xlUp).Row < 5 Then
                .Range("C5:I" & LastRow).Copy desWS.Range("C5")
            Else
                .Range("C5:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "C").End(xlUp).Offset(1, 0)
            End If
            srcWB.Close savechanges:=False
        End With
        fileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Hello Mumps, thank you very much. The code is working fine. But only one issue the code is looking for the file name with Book1, it is not reading the source workbook names. I renamed it to Book1 the code is running perfectly. One more suggestion, workbook name is displaying for all the rows but I want it in the 1st row only. Thanks again.

 

[mumps]

Try:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim desWS As Worksheet
    Set desWS = ActiveWorkbook.Sheets("Summary")
    Dim srcWB As Workbook
    Dim srcWS As Worksheet
    Dim fileName As String
    fileName = Dir(strPath & "*.xlsx")
    Do While fileName <> ""
        Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\" & fileName)
        Set srcWS = srcWB.Sheets("Summary")
        With srcWS
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If desWS.Range("D" & desWS.Rows.Count).End(xlUp).Row < 5 Then
                desWS.Range("C5") = srcWB.Name
                .Range("D5:I" & LastRow).Copy desWS.Range("D5")
            Else
                desWS.Range("C5") = srcWB.Name
                .Range("D5:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "D").End(xlUp).Offset(1, 0)
            End If
            srcWB.Close savechanges:=False
        End With
        fileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[madhuchelliah]

Hello Mumps. my second concern sorted out. But first concern still pops up. The code is not picking the source workbooks. Again it is showing the same error. The error states "sorry we couldn't find C:\users .is it possible it was moved, renamed or deleted?". Thanks for your time.

 

[mumps]

Is the destination workbook in the same folder as all the source workbooks?

 

[madhuchelliah]

Is the destination workbook in the same folder as all the source workbooks?

Yes, all the workbooks are in same folder.

 

[mumps]

I made a slight correction to the code.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim desWS As Worksheet
    Set desWS = ActiveWorkbook.Sheets("Summary")
    Dim srcWB As Workbook
    Dim srcWS As Worksheet
    Dim fileName As String
    fileName = Dir("*.xlsx")
    Do While fileName <> ""
        Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\" & fileName)
        Set srcWS = srcWB.Sheets("Summary")
        With srcWS
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If desWS.Range("D" & desWS.Rows.Count).End(xlUp).Row < 5 Then
                desWS.Range("C5") = srcWB.Name
                .Range("D5:I" & LastRow).Copy desWS.Range("D5")
            Else
                desWS.Range("C" & desWS.Range("D" & Rows.Count).End(xlUp).Row + 1) = srcWB.Name
                .Range("D5:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "D").End(xlUp).Offset(1, 0)
            End If
            srcWB.Close savechanges:=False
        End With
        fileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

The destination and source workbooks must all be in the same folder and the destination workbook must be saved as a macro-enabled file so that its extension changes to "xlsm".

 

[mumps]

Try this version:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim desWS As Worksheet
    Set desWS = ActiveWorkbook.Sheets("Summary")
    Dim srcWB As Workbook
    Dim srcWS As Worksheet
    Dim fileName As String
    ChDir ThisWorkbook.Path
    fileName = Dir("*.xlsx")
    Do While fileName <> ""
        Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\" & fileName)
        Set srcWS = srcWB.Sheets("Summary")
        With srcWS
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If desWS.Range("D" & desWS.Rows.Count).End(xlUp).Row < 5 Then
                desWS.Range("C5") = srcWB.Name
                .Range("D5:I" & LastRow).Copy desWS.Range("D5")
            Else
                desWS.Range("C" & desWS.Range("D" & Rows.Count).End(xlUp).Row + 1) = srcWB.Name
                .Range("D5:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "D").End(xlUp).Offset(1, 0)
            End If
            srcWB.Close savechanges:=False
        End With
        fileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[madhuchelliah]

Try this version:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    Dim desWS As Worksheet
    Set desWS = ActiveWorkbook.Sheets("Summary")
    Dim srcWB As Workbook
    Dim srcWS As Worksheet
    Dim fileName As String
    ChDir ThisWorkbook.Path
    fileName = Dir("*.xlsx")
    Do While fileName <> ""
        Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\" & fileName)
        Set srcWS = srcWB.Sheets("Summary")
        With srcWS
            LastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If desWS.Range("D" & desWS.Rows.Count).End(xlUp).Row < 5 Then
                desWS.Range("C5") = srcWB.Name
                .Range("D5:I" & LastRow).Copy desWS.Range("D5")
            Else
                desWS.Range("C" & desWS.Range("D" & Rows.Count).End(xlUp).Row + 1) = srcWB.Name
                .Range("D5:I" & LastRow).Copy desWS.Cells(desWS.Rows.Count, "D").End(xlUp).Offset(1, 0)
            End If
            srcWB.Close savechanges:=False
        End With
        fileName = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Thank you Mumps. It is working great. Like i mentioned in my first post, it would be better the macro should pick the workbooks in the children folder instead of destination folder. The children folder is in the same folder of destination workbook. Thank you.