Copy Range Values from Closed Workbook from any Worksheet Item

**JackSheet_1** · 06-22-2016, 02:29 PM

Copy Range Values from Closed Workbook from any Worksheet Item

Hi
A quick spin off from a few Threads and Posts.
Function Arguments:
_1) The Function takes as first argument the Full File Path and Name ( As String ) of a closed File.
_2) The second argument is the Range (Rectangular Area of contiguous cells ( greater than 1) ) to be copied ( As a String in “A1:G32” OR “$A1:$C$4” type format )
_3) The Third argument is the Range ( As Range Object ) of Top left of where the Imported Range Values should start.
_4) The Forth optional argument is the Worksheet Name if known, which if known should be given**_.....
_5) **_...The Fifth optional argument is Worksheet Item number (Consecutive number of Tab counting from the left). If this Fifth argument is given, then this will be used rather than the Worksheet Name. This option should only be taken if necessary as the Function is considerably faster if the Worksheet Name is available. ( The Fifth argument when given takes precedence over the Worksheet name, which if also given will be ignored )

Whilst in the Function a CSE entered Array formula of Links to the Range in the Closed Workbook is entered into the receiving Worksheet. The Function Itself returns an Array() of the Range Values.
So if you want to Paste in Links, then you simply
Call LValsClsdWB( ____ )

The returned Array can then be used if necessary to overwrite the CSE Links. So then you would use the Function thus_...
Let arr() = LValsClsdWB( ____ )
_.... and then overwrite the Range of Links
This is demonstrated in the accompanying test Program.

The Function is simplified, ( no error handling etc..) and spared of too many ‘explanations. Detailed explanations and extended Codes are to be found in the referenced Threads and Posts

I tested the code with this data in the second sheet of a closed worksheet, ( “ProAktuelle01.06.2016.xlsx” )

Using Excel 2007 32 bit

_Row\^Col	C	D
3	FromC3	FromD3
4	FromC4	FromD4

Tabelle1

_....

Line 150 to 170 in the Test Sub Routine give these results

_Row\^Col	B	C
2	FromC3	FromD3
3	FromC4	FromD4

Sheet1

_.....

Lines 120 or 130 in the Test Sub Routine give the same values in the Worksheet as above, but in the cells are the following links ( as seen in the Formula Bar )

_Row\^Col	B	C
2	='C:\Users\Elston\Desktop\petra ernährung ab juli\Juni2016\[ProAktuelle01.06.2016.xlsx]Tabelle1'!$C$3:$D$4	='C:\Users\Elston\Desktop\petra ernährung ab juli\Juni2016\[ProAktuelle01.06.2016.xlsx]Tabelle1'!$C$3:$D$4
3	='C:\Users\Elston\Desktop\petra ernährung ab juli\Juni2016\[ProAktuelle01.06.2016.xlsx]Tabelle1'!$C$3:$D$4	='C:\Users\Elston\Desktop\petra ernährung ab juli\Juni2016\[ProAktuelle01.06.2016.xlsx]Tabelle1'!$C$3:$D$4

Sheet1

_.....................

Function and Test code:

Sub TestieFunctionLValsClsdWB()
10   ' Data File info for an arbritrary Test File ( can be closed or "open" )
20   Dim MyFile As String, MyFolder As String
30    Let MyFolder = "C:\Users\Elston\Desktop\petra ernährung ab juli\Juni2016" ' CHANGE TO SUIT any Folder with some files in of .xls .xlsx or .xlsm
40   ' A search criteria to pick first File of type specified in the above folder
50    Let MyFile = Dir(MyFolder & "\*.xlsx")
60   ' Final Full File Path and Name ( Alternative to next Line could be of this form   Dim strWB As String: Let strWB = "C:\myFolder\myExcel2007file.xlsx"   ' etc... etc...
70   Dim strWB As String: Let strWB = MyFolder & "\" & MyFile 'Full Path and Name of current File
80 '
90   ' Arbritrary Top Left of where Imported range should go ' CHANGE TO SUIT
100  Dim rngTL As Range: Set rngTL = ThisWorkbook.Worksheets.Item(1).Range("B2") ' Cell Number 16386 in ab XL2007, 258 in up to XL2003, in first tab counting from the left.
110  ' Use function to get at Range "C3:D4" in second Worksheet of Closed File and Paste Link
120   Call LValsClsdWB(strWB, rngTL, "C$3:D4", , 2)   'Option Sheet index
130   Call LValsClsdWB(strWB, rngTL, "C3:$D4", "Tabelle1")   'Option Sheet Name
140  ' Use function to get at Range "C3:D4" in second Worksheet of Closed File and Paste values
150  Dim arrOut() As Variant 'Type of Ements chosen to suiotvariant Types returned by Function
160   Let arrOut = LValsClsdWB(strWB, rngTL, "C3:D4", "Tabelle1")
170   Let rngTL.Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value = arrOut()
End Sub


'  Function LValsClsdWB(FullFilePathAndName, TopLeftOutputRange, strRangeToCopy ( A1:$F23 ), Sheet Name  or, Sheet Index (Tab number from left)
Public Function LValsClsdWB(FullFilePathAndName As String, rngOutTopLeft As Range, strCells As String, Optional ShtName As String, Optional ShtIndex As Long) As Variant ' Variant Type to return Array of Range Values
' Worksheet name from index determined if necerssary
    If ShtIndex > 1 Then 'Case Sheet Index ( item Number ) is given, takes precedence over the Worksheet Name, and sheet name must be determined
    Dim oRST As Object: Set oRST = CreateObject("ADODB.Recordset"): Dim oConn As Object
    Dim sConnString As String: Let sConnString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FullFilePathAndName & ";Extended Properties=""Excel 12.0 Xml;HDR=No;IMEX=1"";" 'Shoul work for .xls .xlsx and .xlsm Files
     Set oConn = CreateObject("ADODB.Connection"): oConn.Open sConnString: Set oRST = oConn.OpenSchema(20) '20 =adSchemaTables
     oRST.MoveFirst
        Do Until oRST.EOF: Dim Cnt As Long: Let Cnt = Cnt + 1  'Loop through Table names
            If Right(Replace(oRST("TABLE_NAME"), "'", ""), 1) = "$" Then 'All worksheet names end in $ (after the single quotes denoting a field have been removed)
             Let ShtName = Left(oRST("TABLE_NAME"), Len(oRST("TABLE_NAME")) - 1) 'Exclude $ at the end of the tab name
                If Cnt = ShtIndex Then Exit Do ' Leave with current Worksheet name if Count is at Index Number
            End If
             oRST.MoveNext
        Loop
    Else: End If ' Assume we have a determined above or Given Worksheet Name
' Full File Path and Full File Name must be seprated as they are so required in the Link String to be built
Dim FullPath As String: Let FullPath = Left(FullFilePathAndName, (InStrRev(FullFilePathAndName, "\") - 1)) 'Effectively the Folder Path where the File is
Dim FullFileName As String: Let FullFileName = Right(FullFilePathAndName, Len(FullFilePathAndName) - InStrRev(FullFilePathAndName, "\")) 'Full File including extension ( Bit after .  Dot )

' Build required Link String
Dim RCAdres As String: Let RCAdres = Range("" & strCells & "").Address(RowAbsolute:=True, ColumnAbsolute:=True, ReferenceStyle:=xlR1C1, External:=False, RelativeTo:=Cells(32664, 32))
Dim strTemp As String: Let strTemp = "=" & "'" & FullPath & "\" & "[" & FullFileName & "]" & ShtName & "'!" & RCAdres & ""
' Range Dimension Info. ( Any range will do using stringCells )
Dim rws As Long: Let rws = Range("" & strCells & "").Rows.Count: Dim clms As Long: Let clms = Range("" & strCells & "").Columns.Count
'CSE Paste Formula in,.. Note 'Will ask for actualise if File not found, if you say no, you may still get it from the last saves "XML" thing in the Cache. So be aware !!!
Let rngOutTopLeft.Resize(rws, clms).FormulaArray = strTemp ' CSE Paste Formula in,.. Note 'Will ask for actualise if File not found, if you say no, you may still get it from the last saves "XML" thing !!!     http://www.excelforum.com/excel-programming-vba-macros/1126860-is-it-possible-to-sum-entire-column-with-out-opening-excel.html#post4319174
'Finally the Function itself is given a Field of the Range Values to Return
Let LValsClsdWB = rngOutTopLeft.Resize(rws, clms).Value 'Here and, in above Line, the Range object of Top Left cell has the Resize Property applied to return new range Object of increased size. In this line the .Value Property is used which for more than 1 cell returns a Field ( Array() ) of Variant types which can be used in the allowed VBA One Liner to assign these values to an dynamic Array, which in this case the Variant Variable PutACSElinkInGetValue sort of becomes, or rather "houses" this. So this may be returned to an Array. We leave them at Variant types for now rather than doing a loop to convert to string, so hence the Variable assigned to it must be an Array() of Variant types ( or a Variant )
'Clear Object
Set oRST = Nothing: Set oConn = Nothing
End Function