Sub GetLastValueFromColumnFromClosedWorkbookIntoAnArrayWithoutHelperSheet()
'
' This code assumes:
' 1) All files in the folder that is selected are files that you want to get data from.
' 2) There is only one sheet in the files.
' 3) The column to get the data from is the longest or tied for the longest column in the sheet.
' 4) The Results are stored into a newly created workbook, the new workbook is not automatically saved because that was not mentioned as a desire.
'
Dim UserFolderPath As String
'
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False ' Allow only one folder to be selected by user
.Title = "Select a folder that contains the files you are interested in."
.Show ' Show the pop-up box asking for a folder to use
'
If .SelectedItems.Count = 0 Then ' If user cancelled then ...
MsgBox "Operation Cancelled by the user", vbExclamation + vbOKOnly ' Display message box confirming the cancellation
Exit Sub ' Exit the Sub
End If
'
UserFolderPath = .SelectedItems(1) & "\" ' Add a '\' to the end of the folder path selected by the user
End With
'
Application.ScreenUpdating = False ' Turn ScreenUpdating off
'
Dim StartTime As Single
StartTime = Timer ' Start the stop watch
''
Dim ProcessedFiles As Long
Dim AllFiles As Object, CurrentFile As Object, fso As Object
Dim conexion As Object, objCatalog As Object, objRecordSet As Object
Dim ResultsAddress As Range
Dim CodeCompletionTime As Single
Dim AddressForResults As String
Dim ClosedWorkbookString As String
Dim SourceColumn As String
Dim strSQL As String
Dim DataNeededArray As Variant, ResultsArray As Variant
Dim NewWorkbook As Workbook
'
SourceColumn = "E" ' <--- Set this to the Column that you want last value from
AddressForResults = "B1" ' <--- Set this to the cell that you want to display results to
'
Set fso = CreateObject("Scripting.FileSystemObject")
Set AllFiles = fso.GetFolder(UserFolderPath).Files
'
ProcessedFiles = 0 ' Initialize ProcessedFiles to zero
'
ReDim DataNeededArray(1 To 50000, 1 To 4) ' Set Rows & Columns for DataNeededArray
ReDim ResultsArray(1 To 50000) ' Set Rows & Columns for ResultsArray
'
For Each CurrentFile In AllFiles ' Loop through each file in the user selected folder
Set objCatalog = CreateObject("ADOX.Catalog") ' Set up catalog so we can get the sheet name
Set conexion = CreateObject("ADODB.Connection") ' Set up connection so we can connect to the source file
Set objRecordSet = CreateObject("ADODB.Recordset") ' Set up recordset so we can get the Last row
'
On Error GoTo InvalidInput ' If an error is encountered, goto the error handling section
conexion.Open "Provider=MSDASQL.1;Data Source=Excel Files;" & _
"Initial Catalog=" & CurrentFile ' open the connection to the source file
'
objCatalog.ActiveConnection = conexion
SourceSheetName = Replace(objCatalog.Tables(0).Name, "$", "") ' Get sheet name of 1st sheet & Remove $ from end of sheet name
SourceSheetName = Replace(SourceSheetName, "'", "") ' Remove 's from sheet name
'
strSQL = "SELECT Count(*) FROM [" & SourceSheetName & "$]" ' Select all data on the source sheet
'
objRecordSet.Open Source:=strSQL, ActiveConnection:=conexion, _
CursorType:=adOpenForwardOnly, Options:=adCmdText
SourceLastRow = objRecordSet(0) + 1 ' Save Last row number into SourceLastRow
'
On Error GoTo 0 ' Turn off error handling
'
ProcessedFiles = ProcessedFiles + 1 ' Increment the ProcessedFiles counter
DataNeededArray(ProcessedFiles, 1) = UserFolderPath ' Save the folder path
DataNeededArray(ProcessedFiles, 2) = Mid(CurrentFile, InStrRev(CurrentFile, "\") + 1) ' Save the file name
DataNeededArray(ProcessedFiles, 3) = SourceSheetName ' Save the sheet name
DataNeededArray(ProcessedFiles, 4) = SourceColumn & SourceLastRow ' Save address of last row of desired column
'
ClosedWorkbookString = "'" & UserFolderPath & "[" & Mid(CurrentFile, InStrRev(CurrentFile, "\") + 1) & _
"]" & SourceSheetName & "'!" & Range("E" & SourceLastRow).Address(True, True, xlR1C1) ' Save string we will use to get cell value
ResultsArray(ProcessedFiles) = ExecuteExcel4Macro(ClosedWorkbookString) ' Save the value of the cell into ResultsArray
Next
'
ReDim Preserve ResultsArray(1 To ProcessedFiles) ' Resize the ResultsArray to the actual size
'
Set NewWorkbook = Workbooks.Add ' Create a new workbook
Set ResultsAddress = NewWorkbook.Worksheets(1).Range(AddressForResults) ' Set the address to save the results into
'
Range(AddressForResults).Resize(UBound(ResultsArray)) = Application.Transpose(ResultsArray) ' Display ResultsArray to designated location
'
' Clean-Up!
conexion.Close ' close the connection object
'
Set objCatalog = Nothing ' Delete Object
Set conexion = Nothing ' Delete Object
Set objRecordSet = Nothing ' Delete Object
'
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
'
CodeCompletionTime = Timer - StartTime ' Stop the stop watch
CodeCompletionTime = Format(CodeCompletionTime, ".#####") ' Prevent scientific notation results
Debug.Print "Time to complete MoveDataToDifferentSheets = " & CodeCompletionTime & " seconds." ' Display the time elapsed to the user (Ctrl-G)
'
Application.Speech.Speak "This code completed in, , , " & CodeCompletionTime & " seconds." ' Provide audio result
'
Exit Sub ' Exit the Sub
'
InvalidInput:
MsgBox "An error was encountered during processing!", vbExclamation, "Get data from closed workbook" ' Inform user that an error occurred
'
' Clean-Up!
Set objCatalog = Nothing ' Delete Object
Set conexion = Nothing ' Delete Object
Set objRecordSet = Nothing ' Delete Object
End Sub
