Copy specific data from an excel template and paste in new workbook

I have around 100 excel templates in a folder from which I need to extract data from specific cells and put in a separate workbook. Is this something that can be done macro. The logic is MACRO open first template -> Copy Specific Cells -> Paste into new workbook-> Close template-> Proceed open with next template....

The cells(Summary sheet) which we need to copy are E5, D20, C43, D43, C46, D46, C85, D85, C87 and D87. I am attaching sample template and final output file.

Hi

try this

Code:

---

Option Explicit

Sub kTest()
   
    Dim k() As String, i As Long, n As Long, myCells, wbkT  As Workbook
    Dim TemplatePath    As String, FName As String, WbkName As String
    Dim Concat As String
   
    myCells = Array("E5", "D20", "C43", "D43", "C46", "D46", "C85", "D85", "C87", "D87")
   
    TemplatePath = "C:\Test"        '<<<<  adjust the path here
   
    If Right$(TemplatePath, 1) <> Application.PathSeparator Then TemplatePath = TemplatePath & Application.PathSeparator
   
    ReDim k(1 To 150)
   
    FName = Dir(TemplatePath & "*.xls*")
    WbkName = ThisWorkbook.Name
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    Do While Not FName = vbNullString
        If FName <> WbkName Then
            Set wbkT = Workbooks.Open(TemplatePath & FName)
            Concat = vbNullString
            For i = LBound(myCells) To UBound(myCells)
                Concat = IIf(Len(Concat), Concat & "|" & wbkT.Worksheets(1).Range(myCells(i)).Value, wbkT.Worksheets(1).Range(myCells(i)).Value)
            Next
            n = n + 1
            k(n) = Concat
            wbkT.Close 0
            Set wbkT = Nothing
        End If
        FName = Dir()
    Loop
    If n Then
        With Worksheets(1)
            'always overwrite the new data
            .UsedRange.Offset(1).ClearContents
            .Range("a2").Resize(n) = k
            .Range("a2").Resize(n).TextToColumns .Range("A2"), Other:=True, OtherChar:="|"
        End With
    End If
    Application.ScreenUpdating = 1
    Application.DisplayAlerts = 1
   
End Sub

---

Great!!!! Its working like charm.

I have created a folder C:\Test and put 2 sample templates. When i run the macro only information from the 1st template is copied twice(in two rows) in result file.

So information from second template is NOT copied at all.

Please look into it.

Please help..

Can you check that the information in the two templates are not exactly the same?

EDIT: And add a back-slash for the path you specified

"C:\Test\"

I had changed the template name, cell E5 and cell D20..

Quote:

---

Originally Posted by Excel Fox

Can you check that the information in the two templates are not exactly the same?

EDIT: And add a back-slash for the path you specified

"C:\Test\"

---

Quote:

---

Originally Posted by Excel Fox

And add a back-slash for the path you specified

"C:\Test\"

---

That's already been taken care of in the code itself :)

replace

Code:

---

.Range("a2").Resize(n) = k

---

with

Code:

---

.Range("a2").Resize(n) = Application.Transpose(k)

---

Quote:

---

That's already been taken care of in the code itself

---

Yep, my bad. Only later did I notice that there was one whole line 'dedicated' to take care of that. :)

Thank you guys:)