Consolidate Data from Multiple Excel Files from SharePoint to One Excel File

[hahayeahtoast]

Hi All,

I am new to this forum, so if I leave anything essential out or if there are any missteps in my post I apologize in advance and appreciate any feedback.

I am working on a project where we will have many files uploaded to a SharePoint with the same data format. When all files are successfully loaded to SharePoint, we want to have another file pull all of the necessary data out and save into a different file. We currently have this new file created. A button on this file should essentially take all of the necessary data from the files on SharePoint and place it where it is needed in the new file. This can be an extremely slow process, so one of our thoughts was to pull all of the data from SharePoint, create a text file with that data, and then reupload the data from the text file to our consolidated version. Whenever the code is run, after the files have been process, we reeive a Run Time Error '7' Out of Memory error. I believe this is because the text file is not being populated with any data for some reason, although I am open to any other suggestions. I have included the code below and have highlighted the area where the error occurs. I would greatly appreciate any assistance.


Dim fldr As FileDialog 'Placeholder for the selected folder by the user
Dim strFullPath As String
Dim Categories As Variant
Dim Exchange_Rate As Long
Dim k As Integer
Dim sTime As String
Dim Config_LastRow, Source_LastRow As Integer
Dim LastCol, LastRow As Integer
Dim fso As Object
Dim sPathName As String
Dim Key As String
Dim c, q As Integer
Dim Consolidate_Row As Integer
Dim Out_Of_Policy_Flag_Col As Integer

Out_Of_Policy_Flag_Col = 33

Set fso = CreateObject("Scripting.FileSystemObject")
Set Exchange_Rates = CreateObject("Scripting.Dictionary")
Set Budget_File_Names = CreateObject("Scripting.Dictionary")

Application.Calculation = xlCalculationManual
'Application.Calculate

Application.StatusBar = "Starting to Process..."
Application.ScreenUpdating = False 'Turns off screen updating; for example, when the macro opens a budget file, you will just see a _
blank screen. Useful for aesthetics.
Application.DisplayAlerts = False 'Turns off alerts; for example, when a budget file is closed, the "save?" message is not displayed.

sPathName = Application.ActiveWorkbook.Path & "\ZBB_Temp_Files"

If Len(Dir(sPathName, vbDirectory)) > 0 Then
fso.Deletefolder sPathName
End If

MkDir sPathName

Call CopyFilesFromSharepoint(sPathName)

'Set Consolidator workbook and budget file repository, and clear data
'Set wb1 = Workbooks("ConsolidatorLocal_V2.xlsm") 'The consolidator file is named "Consolidator.xlsm" on my computer. Make sure no other files _
are named with this same filename in other folders. This file is assigned to wb1.
Set wb1 = ThisWorkbook

Config_LastRow = wb1.Sheets("Configurations").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Source_LastRow = wb1.Sheets("CPBL_Consolidate").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Out_Of_Policy_LastRow = Sheets("Out_Of_Policy").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

If Source_LastRow > 2 Then
wb1.Sheets("CPBL_Consolidate").Select
wb1.Sheets("CPBL_Consolidate").Rows("3:" & Source_LastRow).Select
Selection.Delete Shift:=xlUp
End If

If Out_Of_Policy_LastRow > 2 Then
Sheets("Out_Of_Policy").Select
Sheets("Out_Of_Policy").Rows("3:" & Out_Of_Policy_LastRow).Select
Selection.Delete Shift:=xlUp
End If

For Each ws In ActiveWorkbook.Worksheets
If ws.Tab.ColorIndex = 5 Or ws.Tab.ColorIndex = 6 Then
On Error Resume Next
ws.Delete
On Error GoTo 0
End If

Next

ActiveWorkbook.Save

Dest_LastRow = wb1.Sheets("CPBL_Consolidate").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

wb1.Sheets("CPBL_Consolidate").Range("A3:BO" & Dest_LastRow + 1).Clear 'Clears any data that was previously populated.

Set objFiles = fso.GetFolder(sPathName).Files
File_Count = objFiles.Count
sTime = TimeValue(Now)

Debug.Print sTime

For Rates = 7 To Config_LastRow
Key = wb1.Sheets("Configurations").Cells(Rates, 1).Value

If Key > "" Then
'Do Nothing
Else
Exit For
End If

If Exchange_Rates.exists(Key) Then
'Do Nothing
Else
Exchange_Rates.Add Key, wb1.Sheets("Configurations").Cells(Rates, 2).Value
End If

Next

sExtract_File_Name = "Budget_Extract_File.txt"

If Len(Dir(sPathName & "\Temp", vbDirectory)) = 0 Then
MkDir sPathName & "\Temp"
End If

sExtract_Full_Name = sPathName & "\Temp\" & sExtract_File_Name

Open sExtract_Full_Name For Output As #2

myFile = Dir(sPathName & "\*.xlsm") 'The macro checks for budget files that are saved with the .xlsm extension. Thus, all files _
should be saved with this format, not .xlsm, etc. The budget preparation directions should also mention this to avoid rework.

k = 1

h = 3

Consolidate_Row = 3

File_Listing_LastRow = wb1.Sheets("File_Name").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

wb1.Sheets("File_Name").Range("A2:F" & File_Listing_LastRow + 1).Clear

'Loop through each budget file to Extract Budget data onto Extract File
Do While myFile <> ""

Set wb2 = Workbooks.Open(FileName:=sPathName & "\" & myFile, UpdateLinks:=False, ReadOnly:=True) 'OpFor Row = 1 To NumRows
Application.ScreenUpdating = False
ActiveWindow.Visible = False
ThisWorkbook.Activate

LastCol = wb2.Sheets("Expense Input").Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
LastRow = wb2.Sheets("Expense Input").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For q = 27 To LastRow

Data = vbNullString

For c = 4 To LastCol

If c = 11 Then
Exchange_Rate = Exchange_Rates.Item(wb2.Worksheets("Expense Input").Cells(q, c).Value)
End If

'Calculate Exchange Rates for Each Dollar Amts
If c > 11 And c < 17 Then
On Error Resume Next
wb2.Worksheets("Expense Input").Cells(q, c).Value = wb2.Worksheets("Expense Input").Cells(q, c).Value * Exchange_Rate
End If

Data = Data & wb2.Worksheets("Expense Input").Cells(q, c).Value & "|"

If c = LastCol Then
Data = Data & myFile & "|"
Print #2, Data
End If

Next c

If wb2.Worksheets("Expense Input").Cells(q, Out_Of_Policy_Flag_Col).Value = "Yes" Then
For c = 1 To LastCol
Sheets("Out_Of_Policy").Cells(h, c).Value = wb2.Worksheets("Expense Input").Cells(q, c + 3).Value
Next

h = h + 1

End If

Next q

sFile_Name = Split(myFile, ".xlsm")

wb1.Sheets("File_Name").Cells(k + 1, 1).Value = wb2.Sheets("Home").Cells(8, 5).Value
wb1.Sheets("File_Name").Cells(k + 1, 2).Value = wb2.Sheets("Home").Cells(16, 5).Value
wb1.Sheets("File_Name").Cells(k + 1, 3).Value = wb2.Sheets("Home").Cells(12, 5).Value
wb1.Sheets("File_Name").Cells(k + 1, 4).Value = wb2.Sheets("Home").Cells(14, 5).Value
wb1.Sheets("File_Name").Cells(k + 1, 5).Value = sFile_Name(0)
Format_File_Listings_Report

Key = sFile_Name(0)

If Budget_File_Names.exists(Key) Then
'Do Nothing
Else
Budget_File_Names.Add Key, Key
End If

myFile = Dir 'Initializes myFile.

wb2.Close savechanges:=False 'Closes the budget file after all sub-category worksheets have been Extracted.

Application.StatusBar = "Processing File " & k & " of " & File_Count & " - " & Round(k / File_Count * 100, 2) & "%"
DoEvents

k = k + 1

Loop

Close #2

Sheets("CPBL_Consolidate").Select

Application.StatusBar = "Importing and Consolidating Budget Files... "

With Sheets("CPBL_Consolidate").QueryTables.Add(Connection:= _
"TEXT;" & sExtract_Full_Name & "", Destination:=Range( _
"$A$3"))
'.CommandType = 0
.Name = "Budget_Extract_File_3"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileOtherDelimiter = "|"
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, _
1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False (This is where the error occurs)
End With


Thank you for all of your help in advance.