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

[excel_1317]

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.

[Admin]

Hi

try this

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

[excel_1317]

Great!!!! Its working like charm.

[excel_1317]

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.

[excel_1317]

Please help..

[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\"

[excel_1317]

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

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\"

[Admin]

And add a back-slash for the path you specified

"C:\Test\"

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

replace

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

with

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

[Excel Fox]

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.

[excel_1317]

Thank you guys