Select only certain columns from closed workbook

Hi Gurus,
Wondering if somebody might be able to assist.

I am currently running the below code to pull data into a spreadsheet from a (dynamic) closed workbook. It is working as it should but i am hopeful that you may have a solution to only pull in certain columns. ie, if the closed workbook has 90 plus columns of data, and I only need column 2, 5, 8 and 17, then only pull those columns in.
Any help would be much appreciated as this appears to be a very resource hungry process!

Function GetValue(path, file, sheet, ref)
'   Retrieves a value from a closed workbook
    Dim arg As String
'   Make sure the file exists
    If Right(path, 1) <> "\" Then path = path & "\"
    If Dir(path & file) = "" Then
        GetValue = "File Not Found"
        Exit Function
    End If
'   Create the argument
    arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
      Range(ref).Range("A1").Address(, , xlR1C1)
'   Execute an XLM macro
    GetValue = ExecuteExcel4Macro(arg)
End Function

Sub Module13()
    Dim Month As String
    Quarter = Range("A298").Value
    p = "S:\SampleData\ThisWorkbook\Excel\" & Quarter & ""
    f = "ExcelForum.xls"
    S = "Data1"
    Application.ScreenUpdating = False
    For r = 207 To 296
        For c = 3 To 96
            a = Cells(r, c).Address
            Cells(r, c) = GetValue(p, f, S, a)
        Next c
    Next r
    Application.ScreenUpdating = True
End Sub

Thanks in advance,
Regards,
Goldfield

Hi Leith,
Thanks for the quick response.
Example attached.
Cheers.

Hi Leith,

Yes I do, but i removed them for confidentiality

This is a use of ExecuteExcel4Macro method all the way, so order should be accurate.

Sub test()
    Dim fn As String, myDir As String, wsName As String, myFile As String
    Dim i As Long, ii As Long, x, y, a, e, myCols
    fn = Application.GetOpenFilename("ExcelFiles,*.xls*")
    If fn = "False" Then Exit Sub
    myDir = Left$(fn, InStrRev(fn, "\"))
    fn = Mid$(fn, InStrRev(fn, "\") + 1)
    wsName = "Data1"
    myFile = "'" & myDir & "[" & fn & "]" & wsName & "'!"
    x = ExecuteExcel4Macro("iferror(match(10^10," & myFile & "c1:c1,1),0)")
    y = ExecuteExcel4Macro("iferror(match(""""," & myFile & "c1:c1,-1),0)")
    x = Application.Max(x, y)
    ReDim a(1 To x, 1 To 4)
    myCols = Array(2, 5, 8, 17)
    For i = 1 To x
        For ii = 0 To UBound(myCols)
            a(i, ii + 1) = ExecuteExcel4Macro(myFile & "r" & i & "c" & myCols(ii))
    Next ii, i
    Cells(1).Resize(x, 4).Value = a
End Sub

Sub Maybe()
Application.ScreenUpdating = False
    With Workbooks.Open("C:\Test\Test.xlsm")    '<------ Change to Path and Workbook Name to be copied FROM
        'In the following line, change the references as required. Sheet to copy FROM and Sheet and Cell to copy INTO
        .Sheets("Sheet2").Range("B:B,E:E,H:H, Q:Q").Copy ThisWorkbook.Sheets("Sheet1").Range("A1")
    End With
ActiveWorkbook.Close False
Application.ScreenUpdating = True
End Sub

ADO
Output in ascending order by 1st column.

Sub testADO()
    Dim fn As String, cn As Object, rs As Object
    Const wsName As String = "Data1"
    fn = Application.GetOpenFilename("ExcelFiles,*.xls*")
    If fn = "" Then Exit Sub
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    With cn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .Properties("Extended Properties") = "Excel 12.0;HDR=No;"
        .Open fn
    End With
    rs.Open "Select F2, F5, F8, F14 From `" & wsName & "$A2:T50000` Where F1 Is Not Null Order By F1;", cn
    Cells(1).CopyFromRecordset rs
    Set cn = Nothing: Set rs = Nothing
End Sub

Hi Leith,
That looks great- thanks! Just wondering if this would also work with data from a closed workbook (without opening them) and what the code might look like. There are a number of sheets that have macros to pull data from different closed workbooks.
Cheers,
Goldfield

Hey Leith- yes, they will be from a single (dynamic) folder path, with different workbook numbers in the folder. The folder path will change depending on the financial quarter and referenced by a cell (A298) in the spreadsheet- shown in code from initial message:

Quarter = Range("A298").Value

Hope this makes sense.

Hi Leith,

Yes- the quarter (cell A298) is auto-populated from a different sheet on the destination workbook. The destination workbook has multiple worksheets (with different macros on each sheet to pull relevant data).
The Source workbooks all contain 3 worksheets (Index, data1, Inquiries) but the data will always be on the sheet called "data1". Nothing is required from the Index or Inquiries sheets.
The data can over write the previous data from column 2 onwards. Column 1 is required for index match purposes. Really appreciate your help on this and I understand it makes it very difficult not having an accurate example to look at!

Hi Leith,

Sorry for any confusion. Please ignore the comment around the index match- I can sort that out at a later date, the main priority is getting the data.
To add to the confusion though...there is a formula in cell A298 = TEXT(C298,"mmmyy") which equals "Jun19".

Data and number formats are the same in both workbooks.

I will attempt to put together a dummy example.

Cheers

Hi Leith,

Yes, the date is in the open workbook (Goldfield Copy).
Please see examples attached. I saved the "Source Sheet" in P:Path1\Path2\Jun19 and adjusted the macro on the destination sheet (Goldfield Copy workbook) to look there.
Hope this makes more sense!
Cheers

Hi Leith,
The quarter is a separate folder ie P:\Path1\path2\Jun19(A298)\SourceSheet.xls, that was the issue.
Sorry if I didn't explain it clearly earlier. I then got an error with dstRng.CurrentRegion not defined, and rng.clrcontents
I managed to get it working in the sample, but have not been able to get it working in the live data as yet.
Regards,
Goldfield

Originally Posted by Leith Ross

Hello Goldfield,

What issues are you having with the live data?

At the moment i can't get it to find the file. In the live version there are 5 folders, the 4th being the dynamic quarter, then the file name. The file name is numeric which i wouldn't have thought would make a difference? E.g. 1234567. xls

I'm getting "The workbook '1234567.xls' was not found in the folder:P:\Path1\Path2\Path3\Path4\Jun19

Hi Leith,
I have now tweaked the code so it works in the live data (see attached). I now need to copy the macro (changing destination and source paths) into a number of other sheets in the same workbook. When I do that, I get a subscript out of range error (also attached). Can you please point me in the direction of where I might be going wrong, and the correct way to go about this?
Cheers,
Goldfield

Sub PullQuarterlyData87520034()

    Dim char As String, cols As Variant, fields As Variant

    Dim fn As String, cn As Object, rs As Object

    Dim Headers As String, Item As Variant, Path As Variant

    Dim dstWks As Worksheet, dstRng As Range, Rng As Range

    Dim srcFile As String, srcWkb As String, srcWks As String

   

    Const adOpenForwardOnly     As Long = 0

    Const adLockReadOnly        As Long = 1

    Const adCmdText             As Long = 1

   

        cols = "C,O,AA,AM,AY,BK,BW,CI"

       

        Set dstWks = ThisWorkbook.Worksheets("87520034")

        Set dstRng = dstWks.Range("A1")

       

        Path = "S:\OUTGRP\8752\Embargoed_Data\Excel\" & dstWks.Range("A297") & "" & "\"

       

        srcWkb = "87520034.xls"

        srcWks = "Data1"

        srcFile = Path & srcWkb

       

            If Dir(srcFile) = "" Then

                MsgBox "The workbook '" & srcWkb & "' was Not Found in the folder: " & vbLf & Path, vbCritical

                Exit Sub

            End If

       

            Set Rng = dstRng

           

            For Each Item In Split(cols, ",")

                fields = fields & char & "F" & dstWks.Cells(1, Item).Column

                Set Rng = Rng.Offset(0, 1)

                char = ","

            Next Item

           

       

           

            Set Rng = dstRng.Offset(0, 1)

            Set Rng = Intersect(Rng, Rng.Offset(1, 1))

               

             

            Set cn = CreateObject("ADODB.Connection")

            Set rs = CreateObject("ADODB.Recordset")

       

            With cn

                .Provider = "Microsoft.ACE.OLEDB.12.0"

                .Properties("Extended Properties") = "Excel 12.0;HDR=No;"

                .Open srcFile

            End With

       

            rs.Open "Select " & fields & " From [" & srcWks & "$] ;", cn, adOpenForwardOnly, adLockReadOnly, adCmdText

            dstRng.Offset(0, 1).CopyFromRecordset rs

       

        cn.Close

        Set cn = Nothing: Set rs = Nothing

        Range("$B$11:$I$295").Select

With Selection

Selection.NumberFormat = "General"

.Value = .Value

Range("$C$303").Select

End With

   

End Sub

It's late here in this part of the world. Leith might be having his beauty sleep already.
In the meantime a possibility that might cause your message.

Subscript out of range indicates that you've tried to access an element from a collection that doesn't exist. Is there a sheet "87520034" in your workbook?
No leading or trailing spaces in it's name?


And also, change this

Range("$B$11:$I$295").Select
With Selection
Selection.NumberFormat = "General"
.Value = .Value
Range("$C$303").Select 
End With

to this

With Range("B11:I295")
     .NumberFormat = "General"
    .Value = .Value
End With
Range("$C$303").Select    '<---- Is this required? If not, leave it out.

Hi Leith,

Current Code attached:

Sub PullQuarterlyData87520034()

    Dim char As String, cols As Variant, fields As Variant

    Dim fn As String, cn As Object, rs As Object

    Dim Headers As String, Item As Variant, Path As Variant

    Dim dstWks As Worksheet, dstRng As Range, Rng As Range

    Dim srcFile As String, srcWkb As String, srcWks As String

   

    Const adOpenForwardOnly     As Long = 0

    Const adLockReadOnly        As Long = 1

    Const adCmdText             As Long = 1

   

        cols = "C,O,AA,AM,AY,BK,BW,CI"

       

        Set dstWks = ThisWorkbook.Worksheets("87520034")

        Set dstRng = dstWks.Range("A1")

       

        Path = "S:\OUTGRP\8752\Embargoed_Data\Excel\" & dstWks.Range("A297") & "" & "\"

       

        srcWkb = "87520034.xls"

        srcWks = "Data1"

        srcFile = Path & srcWkb

       

            If Dir(srcFile) = "" Then

                MsgBox "The workbook '" & srcWkb & "' was Not Found in the folder: " & vbLf & Path, vbCritical

                Exit Sub

            End If

       

            Set Rng = dstRng

           

            For Each Item In Split(cols, ",")

                fields = fields & char & "F" & dstWks.Cells(1, Item).Column

                Set Rng = Rng.Offset(0, 1)

                char = ","

            Next Item

           

       

           

            Set Rng = dstRng.Offset(0, 1)

            Set Rng = Intersect(Rng, Rng.Offset(1, 1))

               

             

            Set cn = CreateObject("ADODB.Connection")

            Set rs = CreateObject("ADODB.Recordset")

       

            With cn

                .Provider = "Microsoft.ACE.OLEDB.12.0"

                .Properties("Extended Properties") = "Excel 12.0;HDR=No;"

                .Open srcFile

            End With

       

            rs.Open "Select " & fields & " From [" & srcWks & "$] ;", cn, adOpenForwardOnly, adLockReadOnly, adCmdText

            dstRng.Offset(0, 1).CopyFromRecordset rs

       

        cn.Close

        Set cn = Nothing: Set rs = Nothing

        .Select

With Range("B11:I295")
     .NumberFormat = "General"
    .Value = .Value
End With



   

End Sub