Reference cell for filename

T

TBIALEK

New Member
Joined
Mar 18, 2016
Messages
24
Hello, Is there a way to reference a cell containing the filename and use is in the formula? I'd like to pull data from different workbooks saved in the folder.
Workbooks will not be opened. Thanks

Capture.PNG
 
Sort by date Sort by votes
TBIALEK said:
I'm using your original "single cell" macro duplicated couple of times with different values and it is working excellent. (in the table)
Could you please modify - if the source file is missing to put "0" automatically in that cell? is this could be done ?


View attachment 48083
Click to expand...
Did you change addresses on me again?
 
Upvote 0

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
VBA Code: 
Option Explicit


Sub GetRangeFromClosedWorkbookV4()                                      '  *** Copy data across row *** Check for missing files *** Adds data to table
'
' This file assumes cell ranges, not a single address
' This file assumes all ranges to be vertical ranges
' This file is not the most efficient, due to the way tables behave, they copy formula down a column each time a formula is copied to a range
'
' Not my proudest work. There has to be a better way!
'
    Dim ColumnOffsetCounter             As Long
    Dim FileNameRow                     As Long
    Dim FirstPartRangeRowNumber         As Long
    Dim LastRowOfFileNames              As Long
    Dim NumberOfSourceRanges            As Long
    Dim NumberOfSourceRangesLoopCounter As Long
    Dim ThisRangeLoopLength             As Long
    Dim SourceRangeLoop                 As Long
    Dim FileExtention                   As String
    Dim FileNotFoundMessage             As String
    Dim FirstPartThisRange              As String
    Dim FirstPartRangeColumn            As String
    Dim ResultColumn                    As String
    Dim SourceDirectory                 As String
    Dim SourceFileAddressColumn         As String
    Dim SourceFileAddressRow            As String
    Dim SourceFileName                  As String
    Dim SourceFileNameStartAddress      As String
    Dim SourceRange1                    As String
    Dim SourceRange2                    As String
    Dim SourceRange3                    As String
    Dim SourceSheet                     As String
    Dim WS                              As Worksheet
'
    Set WS = Sheets("Sheet1")                                                   ' <--- Set this to the sheet name used to store values from the closed workbook
    SourceFileAddressColumn = "F"                                               ' <--- Set this to the column used for Source File Names
    SourceFileAddressRow = "3"                                                  ' <--- Set this to the start row number used for Source File Names
    ResultColumn = "H"                                                          ' <--- Set the column to store results in
    SourceDirectory = "C:\Test\Data\"                                               ' <--- Set this to the directory of the closed workbooks
    FileExtention = ".xlsx"                                                     ' <--- Set this to the file extention of the closed workbook(s) ie. .xlsx
    FileNotFoundMessage = "FNF"                                                 ' <--- set this to cell value indicating file not found
    NumberOfSourceRanges = 3                                                    ' <--- Set this to the number of ranges you want to grab from closed workbook
    SourceRange1 = "B2:B3"                                                      ' <--- Set this to the range in the closed workbook to get data from
    SourceRange2 = "C5:C10"                                                     ' <--- Set this to the range in the closed workbook to get data from
    SourceRange3 = "C15:C20"                                                    ' <--- Set this to the range in the closed workbook to get data from
'
    SourceFileNameStartAddress = SourceFileAddressColumn & SourceFileAddressRow ' Combine Column & Row to form the Start address of the file names
'
    LastRowOfFileNames = WS.Range(SourceFileNameStartAddress).End(xlDown).Row   ' Find Last used row of file names in column
'
    ColumnOffsetCounter = 0                                                     ' Initialize the ColumnOffsetCounter
'
    For NumberOfSourceRangesLoopCounter = 1 To NumberOfSourceRanges
        Select Case NumberOfSourceRangesLoopCounter
            Case 1
                ThisRangeLoopLength = Range(SourceRange1).Cells.Count                   ' Get number of cells in range ... 2
                FirstPartThisRange = Left(SourceRange1, InStr(SourceRange1, ":") - 1)   ' Get first half of range ... "B2"
            Case 2
                ThisRangeLoopLength = Range(SourceRange2).Cells.Count                   ' Get number of cells in range ... x
                FirstPartThisRange = Left(SourceRange2, InStr(SourceRange2, ":") - 1)   ' Get first half of range ... "xx"
            Case 3
                ThisRangeLoopLength = Range(SourceRange3).Cells.Count                   ' Get number of cells in range ... x
                FirstPartThisRange = Left(SourceRange3, InStr(SourceRange3, ":") - 1)   ' Get first half of range ... "xx"
        End Select
'
        FirstPartRangeColumn = Split(Cells(1, Range(FirstPartThisRange).Column).Address, "$")(1)    ' Get column letter from first part of range ... "B"
        FirstPartRangeRowNumber = Range(FirstPartThisRange).Row                                     ' Get row number from first part of range ... 2
'
        For SourceRangeLoop = 0 To ThisRangeLoopLength - 1
            For FileNameRow = SourceFileAddressRow To LastRowOfFileNames                    ' Range of column to loop through
                SourceFileName = WS.Range(SourceFileAddressColumn & FileNameRow)            '   Set Address to use for the file name of closed workbook
                SourceSheet = SourceFileName                                                '   Set the sheet name to use for the closed workbook same as file name
'
                If Dir(SourceDirectory & SourceFileName & FileExtention) <> "" Then         ' If file name exists then ...
                    WS.Range(ResultColumn & FileNameRow).Offset(0, ColumnOffsetCounter).Formula = _
                        "='" & SourceDirectory & "[" & SourceFileName & FileExtention & "]" & SourceSheet & "'!" & FirstPartRangeColumn & (FirstPartRangeRowNumber + SourceRangeLoop)  ' Set Formula to range
                Else                                                                        ' If file name doesn't exist then ...
                    WS.Range(ResultColumn & FileNameRow).Offset(0, ColumnOffsetCounter) = FileNotFoundMessage   ' Indicate file not found
                End If
'
'               Remove formula from column range, leave just the resulting value found in closed workbook
                WS.Range(ResultColumn & SourceFileAddressRow, WS.Range(ResultColumn & LastRowOfFileNames).Offset(0, ColumnOffsetCounter)).Value = _
                    WS.Range(ResultColumn & SourceFileAddressRow, WS.Range(ResultColumn & LastRowOfFileNames).Offset(0, ColumnOffsetCounter)).Value
            Next
'
            ColumnOffsetCounter = ColumnOffsetCounter + 1                           ' Increment the ColumnOffsetCounter
        Next
    Next
MsgBox "Done"                                                                       ' Alert user that range from closed workbook has been loaded to sheet
End Sub
 
Upvote 0
Thank you ! works great! And all data is on the table.
I have last small request, could you please modify "single cell" macro with "FNF" (file not find option) ? I might need it with different application.


Sub GetRangeFromClosedWorkbook()
'
Dim FileNameRow As Long
Dim FirstBlankCellRowInColumnRange As Long
Dim LastRowUsedInColumn As Long
Dim Cell As Range
Dim ColumnRange As Range
Dim DestinationSheet As String
Dim ResultColumn As String
Dim SourceDirectory As String
Dim SourceFileAddressColumn As String
Dim SourceFileAddressRow As String
Dim SourceFileName As String
Dim SourceRange As String
Dim SourceSheet As String
'
DestinationSheet = "Sheet1" ' <--- Set this to the sheet name used to store values from the closed workbook
SourceFileAddressColumn = "A" ' <--- Set this to the column used for Source File Names
SourceFileAddressRow = "5" ' <--- Set this to the start row number used for Source File Names
ResultColumn = "B" ' <--- Set the column to store results in
SourceRange = "$C$38" ' <--- Set this to the range in the closed workbook to get data from
SourceDirectory = "C:\Test\Data\" ' <--- Set this to the directory of the closed workbooks
'
'
LastRowUsedInColumn = Sheets(DestinationSheet).Range(SourceFileAddressColumn & Rows.Count).End(xlUp).Row ' Find Last Used Row in Column
'
' Prep to check for blanks in column range, if so, set last row to the last row of the first section
Set ColumnRange = Sheets(DestinationSheet).Range(SourceFileAddressColumn & SourceFileAddressRow & ":" & SourceFileAddressColumn & LastRowUsedInColumn + 1)
'
For Each Cell In ColumnRange
If Cell.Value = vbNullString Then ' If blank cell found then ...
FirstBlankCellRowInColumnRange = Cell.Row ' Save the row number of the first blank found in the column range
Exit For ' Exit For loop
End If
Next
'
LastRowOfFileNames = FirstBlankCellRowInColumnRange - 1 ' Back up one row number
'
For FileNameRow = SourceFileAddressRow To LastRowOfFileNames ' Range of column to loop through
SourceFileName = SourceFileAddressColumn & FileNameRow ' Set Address to use for the file name of closed workbook
SourceSheet = SourceFileName ' Set the sheet name to use for the closed workbook same as file name
Sheets(DestinationSheet).Range(ResultColumn & FileNameRow).Formula = "='" & SourceDirectory & "[" & Sheets(DestinationSheet).Range(SourceFileName) & ".xlsx]" & SourceSheet & "'!" & SourceRange ' Set Formula to range
'
' Remove formula from range, leave just the resulting value found in closed workbook
Sheets(DestinationSheet).Range(ResultColumn & FileNameRow).Value = Sheets(DestinationSheet).Range(ResultColumn & FileNameRow).Value
Next
'
MsgBox "Done" ' Alert user that range from closed workbook has been loaded to sheet
End Sub
Click to expand...
 
Upvote 0
Put the following toward the top of that code:

VBA Code: 
    Dim FileNotFoundMessage             As String
    FileNotFoundMessage = "FNF"                                                 ' <--- set this to cell value indicating file not found

Then replace the following line:

VBA Code: 
            Sheets(DestinationSheet).Range(ResultColumn & FileNameRow).Formula = "='" & SourceDirectory & "[" & Sheets(DestinationSheet).Range(SourceFileName) & ".xlsx]" & SourceSheet & "'!" & SourceRange  ' Set Formula to range

with:

VBA Code: 
        If Dir(SourceDirectory & SourceFileName & FileExtention) <> "" Then         ' If file name exists then ...
            Sheets(DestinationSheet).Range(ResultColumn & FileNameRow).Formula = "='" & SourceDirectory & "[" & Sheets(DestinationSheet).Range(SourceFileName) & ".xlsx]" & SourceSheet & "'!" & SourceRange  ' Set Formula to range
        Else                                                                        ' If file name doesn't exist then ...
            Sheets(DestinationSheet).Range(ResultColumn & FileNameRow) = FileNotFoundMessage   ' Indicate file not found
        End If
 
Upvote 0
Now that we have done this the slow way, via formulas, I figured we could try a different approach with arrays.

I set it up so you can do the single cells as well as ranges. To do a single cell just set it up like a range for example "B2" would be "B2:B2"

This should be many times faster than the formula approach. Let me know:

VBA Code: 
Sub GetRangeFromClosedWorkbookV5()                                      '  *** Copy data across row *** Check for missing files *** Adds data to table
'
' This file can do single address range as well as multiple cell address ranges
' This file assumes all ranges to be vertical 1D ranges
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim FileNameRow                     As Long
    Dim FirstPartRangeColumnNumber      As Long
    Dim FirstPartRangeRowNumber         As Long
    Dim NumberOfSourceRanges            As Long
    Dim NumberOfSourceRangesLoopCounter As Long
    Dim SourceRowOffsetCounter          As Long
    Dim SourceLastRow                   As Long
    Dim ThisRangeLoopLength             As Long
    Dim ThisRangeLoopCounter            As Long
    Dim SourceRangeLoop                 As Long
    Dim RowArrayList                    As Object
    Dim objCatalog                      As Object
    Dim objConnection                   As Object
    Dim objRecordSet                    As Object
    Dim FileExtention                   As String
    Dim FileNotFoundMessage             As String
    Dim FirstPartThisRange              As String
    Dim FirstPartRangeColumnLetter      As String
    Dim FullFilePathNameExtention       As String
    Dim ResultColumnLetter              As String
    Dim SourceDirectory                 As String
    Dim SourceFileAddressColumn         As String
    Dim SourceFileAddressRow            As String
    Dim SourceFileName                  As String
    Dim SourceFullRange                 As String
    Dim SourceRange1                    As String
    Dim SourceRange2                    As String
    Dim SourceRange3                    As String
    Dim SourceRange4                    As String
    Dim SourceSheet                     As String
    Dim SourceSheetName                 As String
    Dim strConnect                      As String
    Dim strSQL                          As String
    Dim SourceRangeArray                As Variant
    Dim WS                              As Worksheet
'

'
    Set WS = Sheets("Sheet1")                                                   ' <--- Set this to the sheet name used to store values from the closed workbook
    SourceFileAddressColumn = "F"                                               ' <--- Set this to the column used for Source File Names
    SourceFileAddressRow = "3"                                                  ' <--- Set this to the start row number used for Source File Names
    ResultColumnLetter = "H"                                                    ' <--- Set the column to store results in
    SourceDirectory = "C:\Test\Data\"                                           ' <--- Set this to the directory of the closed workbooks
    FileExtention = ".xlsx"                                                     ' <--- Set this to the file extention of the closed workbook(s) ie. .xlsx
    FileNotFoundMessage = "FNF"                                                 ' <--- set this to cell value indicating file not found
'
'   ----------------------------------
'   Range Section - Up to 12 currently
'   ----------------------------------
    NumberOfSourceRanges = 4                                                    ' <--- Set this to the number of ranges you want to grab from closed workbook
    SourceRange1 = "B2:B2"                                                      ' <--- Set this to the range in the closed workbook to get data from
    SourceRange2 = "B3:B3"                                                      ' <--- Set this to the range in the closed workbook to get data from
    SourceRange3 = "C5:C10"                                                     ' <--- Set this to the range in the closed workbook to get data from
    SourceRange4 = "C15:C20"                                                    ' <--- Set this to the range in the closed workbook to get data from
'
    Set RowArrayList = CreateObject("System.Collections.ArrayList")
'
    For FileNameRow = SourceFileAddressRow To WS.Range(SourceFileAddressColumn & SourceFileAddressRow).End(xlDown).Row  ' Range of file names to loop through
        SourceFileName = WS.Range(SourceFileAddressColumn & FileNameRow)        '   Set Address to use for the file name of closed workbook
'
        FullFilePathNameExtention = SourceDirectory & SourceFileName & FileExtention    ' FullFilePathNameExtention
'
        If Dir(SourceDirectory & SourceFileName & FileExtention) <> "" Then     '   If file name exists then ...
            Set objCatalog = CreateObject("ADOX.Catalog")                       '       Set up catalog so we can get the sheet name
            Set objConnection = 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 and range values
'
            strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FullFilePathNameExtention & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
'
            On Error GoTo InvalidInput                                          '       If an error is encountered, goto the error handling section
            objConnection.Open strConnect                                       '       open the connection to the source file
'
            objCatalog.ActiveConnection = objConnection
            SourceSheetName = Replace(objCatalog.Tables(0).Name, "$", "")       '       Remove $ from end of sheet name
            SourceSheetName = Replace(SourceSheetName, "'", "")                 '       Remove 's from sheet name
'
            strSQL = "SELECT Count(*) FROM [" & SourceSheetName & "$]"
            objRecordSet.Open Source:=strSQL, ActiveConnection:=objConnection, CursorType:=adOpenForwardOnly, Options:=adCmdText
            SourceLastRow = objRecordSet(0) + 1                                 '       Save Last row number
'
            SourceFullRange = "A1:E" & SourceLastRow                            '       Set the range of values from source file that we want to put into array
'
            Set objRecordSet = objConnection.Execute("[" & SourceFullRange & "]")
            On Error GoTo 0                                                     '       Turn off error handling
'
            SourceRangeArray = objRecordSet.GetRows                             '       returns a two dimensional array with all values in objRecordSet range
'
            For NumberOfSourceRangesLoopCounter = 1 To NumberOfSourceRanges
                SourceRowOffsetCounter = 0
                Select Case NumberOfSourceRangesLoopCounter
                    Case 1
                        ThisRangeLoopLength = Range(SourceRange1).Cells.Count                               ' Get number of cells in range in SourceRange1
                        FirstPartThisRange = Left(SourceRange1, InStr(SourceRange1, ":") - 1)               ' Get first half of range
'
                    Case 2
                        ThisRangeLoopLength = Range(SourceRange2).Cells.Count                               ' Get number of cells in range in SourceRange2
                        FirstPartThisRange = Left(SourceRange2, InStr(SourceRange2, ":") - 1)               ' Get first half of range
'
                    Case 3
                        ThisRangeLoopLength = Range(SourceRange3).Cells.Count                               ' Get number of cells in range in SourceRange3
                        FirstPartThisRange = Left(SourceRange3, InStr(SourceRange3, ":") - 1)               ' Get first half of range
'
                    Case 4
                        ThisRangeLoopLength = Range(SourceRange4).Cells.Count                               ' Get number of cells in range in SourceRange4
                        FirstPartThisRange = Left(SourceRange4, InStr(SourceRange4, ":") - 1)               ' Get first half of range
'
                    Case 5
                        ThisRangeLoopLength = Range(SourceRange5).Cells.Count                               ' Get number of cells in range in SourceRange5
                        FirstPartThisRange = Left(SourceRange5, InStr(SourceRange5, ":") - 1)               ' Get first half of range
'
                    Case 6
                        ThisRangeLoopLength = Range(SourceRange6).Cells.Count                               ' Get number of cells in range in SourceRange6
                        FirstPartThisRange = Left(SourceRange6, InStr(SourceRange6, ":") - 1)               ' Get first half of range
'
                    Case 7
                        ThisRangeLoopLength = Range(SourceRange7).Cells.Count                               ' Get number of cells in range in SourceRange7
                        FirstPartThisRange = Left(SourceRange7, InStr(SourceRange7, ":") - 1)               ' Get first half of range
'
                    Case 8
                        ThisRangeLoopLength = Range(SourceRange8).Cells.Count                               ' Get number of cells in range in SourceRange8
                        FirstPartThisRange = Left(SourceRange8, InStr(SourceRange8, ":") - 1)               ' Get first half of range
'
                    Case 9
                        ThisRangeLoopLength = Range(SourceRange9).Cells.Count                               ' Get number of cells in range in SourceRange9
                        FirstPartThisRange = Left(SourceRange9, InStr(SourceRange9, ":") - 1)               ' Get first half of range
'
                    Case 10
                        ThisRangeLoopLength = Range(SourceRange10).Cells.Count                              ' Get number of cells in range in SourceRange10
                        FirstPartThisRange = Left(SourceRange10, InStr(SourceRange10, ":") - 1)             ' Get first half of range
'
                    Case 11
                        ThisRangeLoopLength = Range(SourceRange11).Cells.Count                              ' Get number of cells in range in SourceRange11
                        FirstPartThisRange = Left(SourceRange11, InStr(SourceRange11, ":") - 1)             ' Get first half of range
'
                    Case 12
                        ThisRangeLoopLength = Range(SourceRange12).Cells.Count                              ' Get number of cells in range in SourceRange12
                        FirstPartThisRange = Left(SourceRange12, InStr(SourceRange12, ":") - 1)             ' Get first half of range
'
                End Select
'
                FirstPartRangeRowNumber = Range(FirstPartThisRange).Row                                         ' Get row number from first part of range
                FirstPartRangeColumnLetter = Split(Cells(1, Range(FirstPartThisRange).Column).Address, "$")(1)  ' Get column letter from first part of range
                FirstPartRangeColumnNumber = Range(FirstPartRangeColumnLetter & 1).Column                       ' Convert the Column letter to a column number
'
                For ThisRangeLoopCounter = 1 To ThisRangeLoopLength                                             ' Loop through this range
'
                    RowArrayList.Add SourceRangeArray(FirstPartRangeColumnNumber - 1, FirstPartRangeRowNumber - 2 + SourceRowOffsetCounter) ' Add value to array list
                    SourceRowOffsetCounter = SourceRowOffsetCounter + 1                                             ' Increment SourceRowOffsetCounter
                Next
            Next
'
            WS.Range(ResultColumnLetter & FileNameRow).Resize(1, RowArrayList.Count).Value = RowArrayList.ToArray   ' Display contents of array list to row
            RowArrayList.Clear                                                                                      ' Clear all items from the array list
        Else
            WS.Range(ResultColumnLetter & FileNameRow) = FileNotFoundMessage                                        ' Indicate file not found
        End If
    Next
'
'   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
'
    MsgBox "Done."
'
    Exit Sub
'
InvalidInput:
    MsgBox "The FullFilePathNameExtention or source range is invalid!", vbExclamation, "Get data from closed workbook"  ' Inform user that an error occurred
     Set objRecordSet = Nothing                                                                                         ' Delete Object
    Set objConnection = Nothing                                                                                         ' Delete Object
'
'   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
 
Upvote 0
Here it is shortened up and made more user friendly as far as the desired workbook ranges:

VBA Code: 
Sub GetRangeFromClosedWorkbookV6()                                      '  *** Copy data across row *** Check for missing files *** Adds data to table
'
' This file can do single address range as well as multiple cell address ranges
' This file assumes all ranges to be vertical 1D ranges
'
'
'   Turn Settings off
      Application.ScreenUpdating = False                                    ' Turn Screen Updating off
         Application.Calculation = xlCalculationManual                      ' Turn AutoCalculation off
        Application.EnableEvents = False                                    ' Turn EnableEvents off
'
    Dim FileNameRow As Long, FirstPartRangeColumnNumber As Long, FirstPartRangeRowNumber As Long, SourceRowOffsetCounter As Long
    Dim SourceLastRow  As Long, ThisRangeLoopLength As Long, ThisRangeLoopCounter As Long, SourceRangeLoop As Long
'
    Dim objCatalog As Object, objConnection As Object, objRecordSet As Object, RowArrayList As Object
'
    Dim FileExtention As String, FileNotFoundMessage As String, FirstPartThisRange As String, FirstPartRangeColumnLetter As String
    Dim FullFilePathNameExtention As String, ResultColumnLetter As String, SourceDirectory As String, SourceFileAddressColumn As String
    Dim SourceFileAddressRow As String, SourceFileName As String, SourceFullRange As String, SourceSheet As String
    Dim SourceSheetName As String, strConnect As String, strSQL As String
'
    Dim SourceRange As Variant, SourceRangesArray As Variant, SourceWorkbookArray As Variant
'
    Dim WS As Worksheet
'
'--------------------------------------------------------------------------------------
'
    Set WS = Sheets("Sheet1")                                                   ' <--- Set this to the sheet name used to store values from the closed workbook
    SourceFileAddressColumn = "F"                                               ' <--- Set this to the column used for Source File Names
    SourceFileAddressRow = "3"                                                  ' <--- Set this to the start row number used for Source File Names
    ResultColumnLetter = "H"                                                    ' <--- Set the column to store results in
    SourceDirectory = "C:\Test\Data\"                                               ' <--- Set this to the directory of the closed workbooks
    FileExtention = ".xlsx"                                                     ' <--- Set this to the file extention of the closed workbook(s) ie. .xlsx
    FileNotFoundMessage = "FNF"                                                 ' <--- set this to cell value indicating file not found
'
'   Add/Remove as many ranges that you want
    SourceRangesArray = Array("B2:B2", "B3:B3", "C5:C10", "C15:C20")            ' <--- Set this to the ranges in the closed workbook to get data from
'
'--------------------------------------------------------------------------------------
'
    Set RowArrayList = CreateObject("System.Collections.ArrayList")
'
    For FileNameRow = SourceFileAddressRow To WS.Range(SourceFileAddressColumn & SourceFileAddressRow).End(xlDown).Row  ' Range of file names to loop through
        SourceFileName = WS.Range(SourceFileAddressColumn & FileNameRow)        '   Set Address to use for the file name of closed workbook
'
        FullFilePathNameExtention = SourceDirectory & SourceFileName & FileExtention    ' FullFilePathNameExtention
'
        If Dir(SourceDirectory & SourceFileName & FileExtention) <> "" Then     '   If file name exists then ...
            Set objCatalog = CreateObject("ADOX.Catalog")                       '       Set up catalog so we can get the sheet name
            Set objConnection = 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 and range values
'
            strConnect = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FullFilePathNameExtention & ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
'
            On Error GoTo InvalidInput                                          '       If an error is encountered, goto the error handling section
            objConnection.Open strConnect                                       '       open the connection to the source file
'
            objCatalog.ActiveConnection = objConnection
            SourceSheetName = Replace(objCatalog.Tables(0).Name, "$", "")       '       Remove $ from end of sheet name
            SourceSheetName = Replace(SourceSheetName, "'", "")                 '       Remove 's from sheet name
'
            strSQL = "SELECT Count(*) FROM [" & SourceSheetName & "$]"
            objRecordSet.Open Source:=strSQL, ActiveConnection:=objConnection, CursorType:=adOpenForwardOnly, Options:=adCmdText
            SourceLastRow = objRecordSet(0) + 1                                 '       Save Last row number
'
            SourceFullRange = "A1:E" & SourceLastRow                            '       Set the range of values from source file that we want to put into array
'
            Set objRecordSet = objConnection.Execute("[" & SourceFullRange & "]")
            On Error GoTo 0                                                     '       Turn off error handling
'
            SourceWorkbookArray = objRecordSet.GetRows                          '       returns a two dimensional array with all values in objRecordSet range
'
'--------------------------------------------------------------------------------------
'
            For Each SourceRange In SourceRangesArray                                                           ' Load all Source range values to array list
                SourceRowOffsetCounter = 0                                                                      ' Reset SourceRowOffsetCounter
'
                ThisRangeLoopLength = Range(SourceRange).Cells.Count                                            ' Get number of cells in range
                FirstPartThisRange = Left(SourceRange, InStr(SourceRange, ":") - 1)                             ' Get first half of range
'
                FirstPartRangeRowNumber = Range(FirstPartThisRange).Row                                         ' Get row number from first part of range
                FirstPartRangeColumnLetter = Split(Cells(1, Range(FirstPartThisRange).Column).Address, "$")(1)  ' Get column letter from first part of range
                FirstPartRangeColumnNumber = Range(FirstPartRangeColumnLetter & 1).Column                       ' Convert the Column letter to a column number
'
                For ThisRangeLoopCounter = 1 To ThisRangeLoopLength                                             ' Loop through this range
                    RowArrayList.Add SourceWorkbookArray(FirstPartRangeColumnNumber - 1, FirstPartRangeRowNumber - 2 + SourceRowOffsetCounter) ' Add value to array list
                    SourceRowOffsetCounter = SourceRowOffsetCounter + 1                                             ' Increment SourceRowOffsetCounter
                Next
            Next
'
            WS.Range(ResultColumnLetter & FileNameRow).Resize(1, RowArrayList.Count).Value = RowArrayList.ToArray   ' Display contents of array list to row
            RowArrayList.Clear                                                                                      ' Clear all items from the array list
        Else
            WS.Range(ResultColumnLetter & FileNameRow) = FileNotFoundMessage                                        ' Indicate file not found
        End If
    Next
'
'--------------------------------------------------------------------------------------
'
'   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
'
    MsgBox "Done."
'
    Exit Sub
'
InvalidInput:
    MsgBox "The FullFilePathNameExtention or source range is invalid!", vbExclamation, "Get data from closed workbook"  ' Inform user that an error occurred
     Set objRecordSet = Nothing                                                                                         ' Delete Object
    Set objConnection = Nothing                                                                                         ' Delete Object
'
'   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
 
Upvote 0
Thanks for posting last two macros. I did not have a chance to test them yet.
I'm working with "single cell" macro to implement "FNF" file not found option. I did modify macro per your instructions (Friday at 2:01Pm) and now I'm getting "FNF" in all cells.
Could you please look into this ?

Sub Macro1()
'
Dim FileNameRow As Long
Dim FirstBlankCellRowInColumnRange As Long
Dim LastRowUsedInColumn As Long
Dim Cell As Range
Dim ColumnRange As Range
Dim DestinationSheet As String
Dim ResultColumn As String
Dim SourceDirectory As String
Dim SourceFileAddressColumn As String
Dim SourceFileAddressRow As String
Dim SourceFileName As String
Dim SourceRange As String
Dim SourceSheet As String
Dim FileNotFoundMessage As String
FileNotFoundMessage = "FNF" ' <--- set this to cell value indicating file not found
'
DestinationSheet = "Sheet1" ' <--- Set this to the sheet name used to store values from the closed workbook
SourceFileAddressColumn = "E" ' <--- Set this to the column used for Source File Names
SourceFileAddressRow = "5" ' <--- Set this to the start row number used for Source File Names
ResultColumn = "F" ' <--- Set the column to store results in
SourceRange = "$B$2" ' <--- Set this to the range in the closed workbook to get data from
SourceDirectory = "C:\Users\tbialek\Google Drive\CA1\Test_01\Data Files\" '<--- Set this to the directory of the closed workbooks
'
'
LastRowUsedInColumn = Sheets(DestinationSheet).Range(SourceFileAddressColumn & Rows.Count).End(xlUp).Row ' Find Last Used Row in Column
'
' Prep to check for blanks in column range, if so, set last row to the last row of the first section
Set ColumnRange = Sheets(DestinationSheet).Range(SourceFileAddressColumn & SourceFileAddressRow & ":" & SourceFileAddressColumn & LastRowUsedInColumn + 1)
'
For Each Cell In ColumnRange
If Cell.Value = vbNullString Then ' If blank cell found then ...
FirstBlankCellRowInColumnRange = Cell.Row ' Save the row number of the first blank found in the column range
Exit For ' Exit For loop
End If
Next
'
LastRowOfFileNames = FirstBlankCellRowInColumnRange - 1 ' Back up one row number
'
For FileNameRow = SourceFileAddressRow To LastRowOfFileNames ' Range of column to loop through
SourceFileName = SourceFileAddressColumn & FileNameRow ' Set Address to use for the file name of closed workbook
SourceSheet = SourceFileName ' Set the sheet name to use for the closed workbook same as file name
If Dir(SourceDirectory & SourceFileName & FileExtention) <> "" Then ' If file name exists then ...
Sheets(DestinationSheet).Range(ResultColumn & FileNameRow).Formula = "='" & SourceDirectory & "[" & Sheets(DestinationSheet).Range(SourceFileName) & ".xlsx]" & SourceSheet & "'!" & SourceRange ' Set Formula to range
Else ' If file name doesn't exist then ...
Sheets(DestinationSheet).Range(ResultColumn & FileNameRow) = FileNotFoundMessage ' Indicate file not found
End If
'
' Remove formula from range, leave just the resulting value found in closed workbook
Sheets(DestinationSheet).Range(ResultColumn & FileNameRow).Value = Sheets(DestinationSheet).Range(ResultColumn & FileNameRow).Value
Next
'
'MsgBox "Done" ' Alert user that range from closed workbook has been loaded to sheet
End Sub
Click to expand...


Screenshot 2021-10-04 080137.png
 
Upvote 0
Replace:

VBA Code: 
        If Dir(SourceDirectory & SourceFileName & FileExtention) <> "" Then         ' If file name exists then ...

with:

VBA Code: 
        If Dir(SourceDirectory & Sheets(DestinationSheet).Range(SourceFileName) & ".xlsx") <> "" Then     ' If file name exists then ...
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
VBA Script - Can't figure out one error...
2
Replies
15
Views
240
Peter_SSs
Peter_SSs
J
  • Question
Power Query - Data Refresh Error in Macro
Replies
3
Views
134
bobsan42
bobsan42
S
  • Solved
Filename formula not working
Replies
3
Views
137
Alex Blakenburg
A
G
  • Question
Open workbooks in folder and run Macro in each book
Replies
7
Views
364
glynn1969
G
S
  • Question
Open and print a section of word document as pdf
Replies
6
Views
200
StephenBart
S

Forum statistics

Threads
1,214,981
Messages
6,122,566
Members
449,089
Latest member
Motoracer88

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top