Pull data from closed workbooks in same folder

[ceytl]

Hello,

I have been looking for VBA script that can go into all the closed .xlsx files in a folder called S1 and grab the data from cells B5, H7, F19, F20, F21, and then put these values in A2, B2, C2, D2, E2

There is about 100 files, and the path is: c:\Users\US\Desktop\S1

is this something that can be done?

Thanks,

 

[johnnyL]

Glad to help @ceytl.

 

[oldvanman]

'
'   Apostrophe in file name is now handled :)
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim MyCell                  As Range
    Dim DestinationSheetName    As String, SourceDirectory As String, SourcefileName As String, SourceSheetName As String
    Dim DestinationRow          As Long
    Dim conexion                As Object, objCat As Object
'
    DestinationSheetName = "Worksheet"                                                  ' <--- Set this to the Destination Sheet Name
    DestinationRow = 2                                                                  ' <--- Set this to the top row for the results
    SourceDirectory = "C:\Users\thomas\Invoices2019-2021\"                              ' <--- Set this to the folder name that contains the source files
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name
'
    Set conexion = CreateObject("adodb.connection")
      Set objCat = CreateObject("ADOX.Catalog")
'
    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        SourcefileName = Replace(SourcefileName, "'", "''")                             ' replace any apostrophe in file name with a double apostrophe
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow)
        MyCell.Offset(, 0).Resize(1, 4).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G25:G28" & ")"
        MyCell.Offset(, 4).Resize(1, 3).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G34:G36" & ")"
        MyCell.Offset(, 7).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G39"
'
        SourcefileName = Dir
    Loop
'
    With ThisWorkbook.Sheets(DestinationSheetName).UsedRange
        .Value = .Value                                                                         ' Remove formulas, leaving just the values
    End With
'
      Set objCat = Nothing
    Set conexion = Nothing
'
'   Turn Settings back on
      Application.EnableEvents = True                                                           ' Turn EnableEvents back on
       Application.Calculation = xlCalculationAutomatic                                         ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub

Hi,
Very new to VBA.
I have a very similar issue to @ceytl in that I am looking to get data from my invoices2019-2021 files. Each file can have a number of worksheets but the data will come from Service invoice and Cells B10, E4,E5,E29.E31,E33 and E34
Destination is Worksheet staring at Cell A2,B2,C2....... filling each row consecutively down the sheet with the service invoice data.

I would not want to open each .xlsx files in the folder.

I have tried to use and adapt @jonnyL code above

Hope you can help
Thanks

 

[johnnyL]

I haven't tested but I think the following should do what you want:

Sub PullDatafomClosedWBV3()
'
'   This macro will use the sheet name from a closed xlsx workbook and then get data from that sheet name.
'   It works with numbers, spaces and ' Workbook remains closed the entire time.
'
'   Apostrophe in file name is now handled :)
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim MyCell                  As Range
    Dim DestinationSheetName    As String, SourceDirectory As String, SourcefileName As String, SourceSheetName As String
    Dim DestinationRow          As Long
    Dim conexion                As Object, objCat As Object
'
    SourceSheetName = "Service invoice"                                                 ' <--- Set this to the name of the sheet in the closed workbook
    DestinationSheetName = "Unit_Data"                                                  ' <--- Set this to the Destination Sheet Name
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results minus 1
    SourceDirectory = ActiveWorkbook.Path & "\Orders\"                                  ' <--- Set this to the folder name that contains the source files
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name
'
    Set conexion = CreateObject("adodb.connection")
      Set objCat = CreateObject("ADOX.Catalog")
'
    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
''        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
''        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        SourcefileName = Replace(SourcefileName, "'", "''")                             ' replace any apostrophe in file name with a double apostrophe
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow)
        MyCell.Offset(, 0).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!B10"
        MyCell.Offset(, 1).Resize(1, 2).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E4:E5" & ")"
        MyCell.Offset(, 3).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E29"
        MyCell.Offset(, 4).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E31"
        MyCell.Offset(, 5).Resize(1, 2).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E33:E34" & ")"
'
        SourcefileName = Dir
    Loop
'
    With ThisWorkbook.Sheets(DestinationSheetName).UsedRange
        .Value = .Value                                                                         ' Remove formulas, leaving just the values
    End With
'
      Set objCat = Nothing
    Set conexion = Nothing
'
'   Turn Settings back on
      Application.EnableEvents = True                                                           ' Turn EnableEvents back on
       Application.Calculation = xlCalculationAutomatic                                         ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub

Be sure to make any changes needed at the top of the code that have arrows on the right side comments.

 

[oldvanman]

Hi JohnnyL

Thanks for the reply sorry in the delay getting back to, been away for a few days good November weather in the UK!
As I press F8 the code stops on SourceFileName. and shows code 52
Is the problem the final folder name
The full file path is C:\Users\Thomas\Invoices 2019-2020\Inv 123 as an example, this folder number changes for each invoice.
Sheet 1 = Service Invoice

Thanks again for your help.

Dim MyCell                  As Range
    Dim DestinationSheetName    As String, SourceDirectory As String, SourcefileName As String, SourceSheetName As String
    Dim DestinationRow          As Long
    Dim conexion                As Object, objCat As Object
'
    SourceSheetName = "Service Invoice"                                                 ' <--- Set this to the name of the sheet in the closed workbook
    DestinationSheetName = "Worksheet"                                                  ' <--- Set this to the Destination Sheet Name
    DestinationRow = 2                                                                  ' <--- Set this to the top row for the results minus 1
    SourceDirectory = ActiveWorkbook.Path & "C:\Users\Thomas\Invoices2019-2021\"        ' <--- Set this to the folder name that contains the source files
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name

'

 

[johnnyL]

Couple issues:

    SourceDirectory = ActiveWorkbook.Path & "C:\Users\Thomas\Invoices2019-2021\"        ' <--- Set this to the folder name that contains the source files

You need to remove the beginning part of that, the 'ActiveWorkbook.Path & '

So you would be left with:

    SourceDirectory = "C:\Users\Thomas\Invoices2019-2021\"        ' <--- Set this to the folder name that contains the source files

Hi JohnnyL

Thanks for the reply sorry in the delay getting back to, been away for a few days good November weather in the UK!
As I press F8 the code stops on SourceFileName. and shows code 52
Is the problem the final folder name
The full file path is C:\Users\Thomas\Invoices 2019-2020\Inv 123 as an example, this folder number changes for each invoice.
[\Quote]

You have 'Invoices 2019-2020' there but in the code you have 'Invoices2019-2021' <--- check your spacing and naming in that line

 

[oldvanman]

Hi Thank again for this help.

Sub PullDatafomClosedWBV3()
'
'   This macro will use the sheet name from a closed xlsx workbook and then get data from that sheet name.
'   It works with numbers, spaces and ' Workbook remains closed the entire time.
'
'   Apostrophe in file name is now handled :)
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim MyCell                  As Range
    Dim DestinationSheetName    As String, SourceDirectory As String, SourcefileName As String, SourceSheetName As String
    Dim DestinationRow          As Long
    Dim conexion                As Object, objCat As Object
'
    SourceSheetName = "Service Invoice"                                                 ' <--- Set this to the name of the sheet in the closed workbook
    DestinationSheetName = "Worksheet"                                                  ' <--- Set this to the Destination Sheet Name
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results minus 1
    SourceDirectory = "C:\Users\Thomas\Invoices2019-2021\"                              ' <--- Set this to the folder name that contains the source files
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name
'
    Set conexion = CreateObject("adodb.connection")
      Set objCat = CreateObject("ADOX.Catalog")
'
    Do While SourcefileName <> ""=
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
''        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
''        SourceSheetName = Replace(SourceSheetName, "'", "")

        conexion.Close
'
        SourcefileName = Replace(SourcefileName, "'", "''")                             ' replace any apostrophe in file name with a double apostrophe
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow)
        MyCell.Offset(, 0).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!B10"
        MyCell.Offset(, 1).Resize(1, 2).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E4:E5" & ")"
        MyCell.Offset(, 3).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E29"
        MyCell.Offset(, 4).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E31"
        MyCell.Offset(, 5).Resize(1, 2).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E33:E34" & ")"
'
        SourcefileName = Dir
    Loop
'
    With ThisWorkbook.Sheets(DestinationSheetName).UsedRange
        .Value = .Value                                                                         ' Remove formulas, leaving just the values
    End With
'
      Set objCat = Nothing
    Set conexion = Nothing
'
'   Turn Settings back on
      Application.EnableEvents = True                                                           ' Turn EnableEvents back on
       Application.Calculation = xlCalculationAutomatic                                         ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub

So I updated the Sourcedirectory as suggested.

Now I can step down to Do While SourcefileName <> "" and it will jump to With ThisWorkbook.Sheets(DestinationSheetName).UsedRange is this correct?

I presume that the SourcefileName will look for any file that is a *.xlsx in the SourceDirectory and then look for the SourceSheetName ="Service Invoice"
No results appear in the Invoice Register 1.xlsx

Thank for your help

 

[johnnyL]

That jump means that there are no .xlsx files in the SourceDirectory, or the SourceDirectory was not found.

 

[oldvanman]

That jump means that there are no .xlsx files in the SourceDirectory, or the SourceDirectory was not found.

Hi jonnyL.
That was my thinking so I added an Inv 291 to the source directory and the data was collected.
I have uploaded a image, can I change the Inv xxx folder automatically for each of the invoices as the service invoice is in each of the Inv xxx folders?

 

[johnnyL]

Try this out:

Option Explicit
'
    Dim NotFirstIteration       As Boolean
    Dim OldestFileDate          As Date
    Dim OldestFilePath_Name     As String
    Dim FileExt                 As String
    Dim fso                     As Object
    Dim conexion                As Object, objCat           As Object
    Dim DestinationRow          As Long
    Dim DestinationSheetName    As String, SourceSheetName  As String
'


Sub GetDataFrom_Folder_SubFolders()
'
'   Turn Settings off
      Application.ScreenUpdating = False                                        ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                          ' Turn AutoCalculation off
        Application.EnableEvents = False                                        ' Turn EnableEvents off
'
    Dim SourceDirectoryPath As String
'
         Set fso = CreateObject("Scripting.FileSystemObject")
    Set conexion = CreateObject("adodb.connection")
      Set objCat = CreateObject("ADOX.Catalog")
'
    SourceSheetName = "Service invoice"                                         ' <--- Set this to the name of the sheet in the closed workbook
    DestinationSheetName = "Worksheet"                                          ' <--- Set this to the Destination Sheet Name
    DestinationRow = 2                                                          ' <--- Set this to the top row for the results
    SourceDirectoryPath = "C:\Users\Thomas\Invoices2019-2021\"                  ' <--- Set this to the proper folder that you want to search through
'
    Call FindFilesInFolders(SourceDirectoryPath, Array("xlsx")) ' <---Set this to the extention of files you want to search for ...ie txt or xlsm or xlsx etc
''    Call FindFilesInFolders(SourceDirectoryPath, Array("txt", "xlsx"))
'
    With ThisWorkbook.Sheets(DestinationSheetName).UsedRange
        .Value = .Value                                                         ' Remove formulas, leaving just the values
    End With
'
      Set objCat = Nothing
    Set conexion = Nothing
'
'   Turn Settings back on
      Application.EnableEvents = True                                           ' Turn EnableEvents back on
       Application.Calculation = xlCalculationAutomatic                         ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                           ' Turn Screen Updating back on
End Sub



Sub FindFilesInFolders(ByVal SourceDirectory As String, FileTypes As Variant)
'
'   Recursive procedure for iterating through all files of specific file types, by file extension, in a folder and subfolders.
'
    Dim AllFiles        As Object
    Dim CurrentFile     As Object
    Dim SubFolder       As Object
    Dim MyCell          As Range
    Dim SourcefileName  As String
    Dim SourcePath      As String
'
    Set AllFiles = fso.GetFolder(SourceDirectory)
'
'   iterate through all files in the root of the main folder
    If Not NotFirstIteration Then
        For Each CurrentFile In AllFiles.Files
            FileExt = fso.GetExtensionName(CurrentFile.Path)
'
'           check if current file matches one of the specified file types
            If Not IsError(Application.Match(FileExt, FileTypes, 0)) Then
                conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & CurrentFile & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
                Set objCat.ActiveConnection = conexion
'
                conexion.Close
'
                SourcefileName = fso.GetFileName(CurrentFile)
                SourcefileName = Replace(SourcefileName, "'", "''")                             ' replace any apostrophe in file name with a double apostrophe
'
                Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow)
                MyCell.Offset(, 0).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!B10"
                MyCell.Offset(, 1).Resize(1, 2).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E4:E5" & ")"
                MyCell.Offset(, 3).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E29"
                MyCell.Offset(, 4).Formula = "='" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E31"
                MyCell.Offset(, 5).Resize(1, 2).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!E33:E34" & ")"
'
                DestinationRow = DestinationRow + 1
            End If
        Next
'
'       make recursive call, if main folder contains subfolder
        If Not AllFiles.SubFolders Is Nothing Then
            NotFirstIteration = True
            Call FindFilesInFolders(SourceDirectory, FileTypes)
        End If
    Else
'       iterate through all files in all the subfolders of the main folder
        For Each SubFolder In AllFiles.SubFolders
            For Each CurrentFile In SubFolder.Files
                FileExt = fso.GetExtensionName(CurrentFile.Path)
'
'               check if current file matches one of the specified file types
                If Not IsError(Application.Match(FileExt, FileTypes, 0)) Then
                    conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & CurrentFile & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
                    Set objCat.ActiveConnection = conexion
                    conexion.Close
'
                    SourcefileName = fso.GetFileName(CurrentFile)
                    SourcefileName = Replace(SourcefileName, "'", "''")                     ' replace any apostrophe in file name with a double apostrophe
                    SourcePath = SubFolder & "\"
'
                    Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow)
                    MyCell.Offset(, 0).Formula = "='" & SourcePath & "[" & SourcefileName & "]" & SourceSheetName & "'!B10"
                    MyCell.Offset(, 1).Resize(1, 2).FormulaArray = "=Transpose('" & SourcePath & "[" & SourcefileName & "]" & SourceSheetName & "'!E4:E5" & ")"
                    MyCell.Offset(, 3).Formula = "='" & SourcePath & "[" & SourcefileName & "]" & SourceSheetName & "'!E29"
                    MyCell.Offset(, 4).Formula = "='" & SourcePath & "[" & SourcefileName & "]" & SourceSheetName & "'!E31"
                    MyCell.Offset(, 5).Resize(1, 2).FormulaArray = "=Transpose('" & SourcePath & "[" & SourcefileName & "]" & SourceSheetName & "'!E33:E34" & ")"
'
                    DestinationRow = DestinationRow + 1
                End If
            Next
'
'           make recursive call, if subfolder contains subfolders
            If Not SubFolder.SubFolders Is Nothing Then
                Call FindFilesInFolders(SourceDirectory & "\" & SubFolder.Name, FileTypes)
            End If
        Next
    End If
'
    NotFirstIteration = False
End Sub

It will look for files in the C:\Users\Thomas\Invoices2019-2021\ as well as any folders (sub folders) within that. So no need to worry about adding the 'Invxxx' anywhere in the code.

 

[ceytl]

Glad to help @ceytl.

johnnyL

Wondering if you could help.

When I run the code below it does not work, because I have a dash "-" in the file name:

Examples:
open-order 2021_AU.xlxs
Order - 654G.xlxs

There is: SourcefileName = Replace(SourcefileName, "-", "''") ...but that doesen't seem to work.

Any ideas?

Thanks!

Sub PullDatafomClosedWB_V6()
'
'   This macro will get the first alphabetical sheet name from a closed xlsx workbook and then get data from that sheet name.
'   It works with numbers, spaces and ' Workbook remains closed the entire time.
'
'   Apostrophe in file name is now handled :)
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim MyCell                  As Range
    Dim DestinationSheetName    As String, SourceDirectory As String, SourcefileName As String, SourceSheetName As String
    Dim DestinationRow          As Long
    Dim conexion                As Object, objCat As Object
'
    DestinationSheetName = "Product"                                                  ' <--- Set this to the Destination Sheet Name
    DestinationRow = 1                                                                  ' <--- Set this to the top row for the results
    SourceDirectory = ActiveWorkbook.Path & "\New\"                                  ' <--- Set this to the folder name that contains the source files
    SourcefileName = Dir(SourceDirectory & "*.xlsx")                                    ' Save source file name
'
    Set conexion = CreateObject("adodb.connection")
      Set objCat = CreateObject("ADOX.Catalog")
'
    Do While SourcefileName <> ""
        DestinationRow = DestinationRow + 1
'
        conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & SourceDirectory & SourcefileName & "; Extended Properties=""Excel 12.0; HDR=YES"";"
'
        Set objCat.ActiveConnection = conexion
        SourceSheetName = Replace(objCat.Tables(0).Name, "$", "")
        SourceSheetName = Replace(SourceSheetName, "'", "")
        SourceSheetName = Replace(SourceSheetName, "-", "")

        conexion.Close
'
        SourcefileName = Replace(SourcefileName, "'", "''")                             ' replace any apostrophe in file name with a double apostrophe
        SourcefileName = Replace(SourcefileName, "-", "''")
'
        Set MyCell = ThisWorkbook.Sheets(DestinationSheetName).Range("A" & DestinationRow)
        MyCell.Offset(, 0).Resize(1, 22).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G25:G46" & ")"
        MyCell.Offset(, 22).Resize(1, 13).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G49:G61" & ")"
        MyCell.Offset(, 35).Resize(1, 7).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G64:G70" & ")"
        MyCell.Offset(, 42).Resize(1, 21).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G73:G93" & ")"
        MyCell.Offset(, 63).Resize(1, 6).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G96:G101" & ")"
        MyCell.Offset(, 69).Resize(1, 4).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G104:G107" & ")"
        MyCell.Offset(, 73).Resize(1, 30).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G110:G139" & ")"
        MyCell.Offset(, 103).Resize(1, 5).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G142:G146" & ")"
        MyCell.Offset(, 108).Resize(1, 9).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G149:G157" & ")"
        MyCell.Offset(, 117).Resize(1, 4).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G160:G163" & ")"
        MyCell.Offset(, 121).Resize(1, 17).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G166:G182" & ")"
        MyCell.Offset(, 138).Resize(1, 4).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G185:G188" & ")"
        MyCell.Offset(, 142).Resize(1, 14).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G191:G204" & ")"
        MyCell.Offset(, 156).Resize(1, 2).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G207:G208" & ")"
        MyCell.Offset(, 158).Resize(1, 2).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G211:G212" & ")"
        MyCell.Offset(, 160).Resize(1, 11).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G215:G225" & ")"
        MyCell.Offset(, 171).Resize(1, 14).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G228:G241" & ")"
        MyCell.Offset(, 185).Resize(1, 2).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G244:G245" & ")"
        MyCell.Offset(, 187).Resize(1, 9).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G248:G256" & ")"
        MyCell.Offset(, 196).Resize(1, 36).FormulaArray = "=Transpose('" & SourceDirectory & "[" & SourcefileName & "]" & SourceSheetName & "'!G259:G294" & ")"

'
        SourcefileName = Dir
    Loop
'
    With ThisWorkbook.Sheets(DestinationSheetName).UsedRange
        .Value = .Value                                                                         ' Remove formulas, leaving just the values
    End With
'
      Set objCat = Nothing
    Set conexion = Nothing
'
'   Turn Settings back on
      Application.EnableEvents = True                                                           ' Turn EnableEvents back on
       Application.Calculation = xlCalculationAutomatic                                         ' Turn AutoCalculation back on
    Application.ScreenUpdating = True                                                           ' Turn Screen Updating back on
End Sub