Reference cell for filename

[TBIALEK]

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

 

[TBIALEK]

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 ...

Thank you, work as intended now.

 

[TBIALEK]

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

This also work perfect, except is inserting "FNF" only in the first column:

 

[johnnyL]

Not sure why you need it displayed more than once per row, but you can replace:

            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

with:

            WS.Range(ResultColumnLetter & FileNameRow).Resize(1, RowArrayList.Count).Value = RowArrayList.ToArray   ' Display contents of array list to row
            ArraySize = RowArrayList.Count
            RowArrayList.Clear                                                                                      ' Clear all items from the array list
        Else
            WS.Range(ResultColumnLetter & FileNameRow).Resize(1, ArraySize).Value = FileNotFoundMessage             ' Indicate file not found

 

[TBIALEK]

Like always work great, thanks - much faster then 12 macros...
Is there a way to "skip" a column if I need to do some calculations ? For example - fill columns "F" and "G" skip "H" ? (Fill "I" and "J" skip "K )

 

[johnnyL]

How about:

Sub GetRangeFromClosedWorkbookV7()                                      '  *** 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
'
    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
'
'--------------------------------------------------------------------------------------
'
    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
'
'--------------------------------------------------------------------------------------
'
            ColumnIncrementer = 0
            ColumnSkipCheck = 0
'
            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
                    WS.Range(ResultColumnLetter & FileNameRow).Offset(0, ColumnIncrementer).Value = SourceWorkbookArray(FirstPartRangeColumnNumber - 1, FirstPartRangeRowNumber - 2 + SourceRowOffsetCounter)   ' Display contents to row
                    SourceRowOffsetCounter = SourceRowOffsetCounter + 1                                             ' Increment SourceRowOffsetCounter
                    ColumnIncrementer = ColumnIncrementer + 1
                    ColumnSkipCheck = ColumnSkipCheck + 1
'
                    If ColumnSkipCheck = 2 Then
                        ColumnIncrementer = ColumnIncrementer + 1
                        ColumnSkipCheck = 0
                    End If
                Next
            Next
'
            RowSize = ColumnIncrementer - 1
        Else
            WS.Range(ResultColumnLetter & FileNameRow).Resize(1, RowSize).Value = 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

 

[TBIALEK]

Nice, but is it possible to pick which column I want to skip ? Won`t be more then 2 or 3.