Copy Range from specific sheet of all workbooks in a folder to a template and create new template in the Master sheet

[JoeThomas]

Greetings! I am quite new to this forum and know very little about VBA. Seeking your expertise in a matter that I've been searching for a couple of days to no avail. I am looking for a vba code to copy a Range from a sheet named "Estimation" of multiple workbooks in a folder to a template and the template needs to be duplicated every time for a different workbook. There are many threads for appending data to the same sheet. In my case I need the template to be duplicated in the same Master workbook and then the ranges to be copied from the other workbooks to the new template. If possible, the new template could be renamed to the actual workbooks name or atleast a part of the workbooks name.
The range from Estimation to be copied to the newly created template.
The ranges I need to be copied and pasted is from Sheet named "Estimation" to the Template.
"Q13:R112" to "Q13:R104" & "S13:T104" to "U13:V104"

 

[JLGWhiz]

This assumes that
1. the template workbook will be in the same folder as all the other workbooks and
2, the code will be run from the template workbook
3. the template workbook will be open, and
4. the template sheet will be the active sheet.

Sub t()
Dim sh As Worksheet, ws As Worksheet, wb As Workbook, fPath As String, fName As String
Set sh = ActiveSheet
fPath = ThisWorkbook.Path & "\"
fName = Dir(fPath & "*.xl*")
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
            On Error Resume Next
                wb.Sheets("Estimation").Range("Q13:R112").Copy
                If Err.Number = 0 Then
                    sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    ActiveSheet.Range("Q13").PasteSpecial xlPasteValuesAndNumberFormats
                    wb.Sheets("Estimation").Range("S13:R104").Copy ActiveSheet.Range("U13")
                End If
                On Error GoTo 0
                Err.Clear
                wb.Close False
        End If
        fName = Dir
    Loop
    Beep
    MsgBox "All Sheets have been processed.", vbInformation, "PRCESSING COMPLETE"
End Sub

 

[JoeThomas]

@JLGWhiz - That's splendid! thank you very much... for being so prompt and it does exactly what I want it to do. I'm very grateful! God Bless!!!

 

[JoeThomas]

@JLGWhilz - Just out of Curiosity, is there anyway we can also rename the sheets with the name of the files. Maybe with a string function to accommodate the character length.

 

[JLGWhiz]

See if this works

Sub t2()
Dim sh As Worksheet, ws As Worksheet, wb As Workbook, fPath As String, fName As String
Set sh = ActiveSheet
fPath = ThisWorkbook.Path & "\"
fName = Dir(fPath & "*.xl*")
    Do While fName <> ""
        If fName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(fPath & fName)
            On Error Resume Next
                wb.Sheets("Estimation").Range("Q13:R112").Copy
                If Err.Number = 0 Then
                    sh.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
                    ActiveSheet.Range("Q13").PasteSpecial xlPasteValuesAndNumberFormats
                    wb.Sheets("Estimation").Range("S13:R104").Copy ActiveSheet.Range("U13")
                    ActiveSheet.Name = Left(fName, InStr(fName, ".") - 1)
                End If
                On Error GoTo 0
                Err.Clear
                wb.Close False
        End If
        fName = Dir
    Loop
    Beep
    MsgBox "All Sheets have been processed.", vbInformation, "PRCESSING COMPLETE"
End Sub

 

[JoeThomas]

@JLGWhiz Thank you for your support, it doesn't work though. I tried several times to no avail. Would it be because of an update link prompt that it gives everytime I run the macro? it still does not copy the workbook names to the worksheets. It shows as Template (2), Template (3) and so on.