Opening Multiple IQY Files for full-page queries, saving one cell

I used a previous expert's answer from Excel 2003, but it doesn't seem to work for 2013.

I have a directory with multiple IQY files. Each one is for an intranet page which has data I need, but isn't broken up into tables. The IQY for each page is set to pull the entire page's data and insert it into column A.

Of all of these cells, I only need one (Cell A159).

I was using:

Sub OpenAllIQY()
Dim FName As String, Path As String
  Path = "C:\Users\jjar\Documents\My Data Sources\"
  FName = Dir(Path & "*.iqy")
  While Len(FName) > 0
    OpenIQY Path & FName
    FName = Dir
    Application.Wait TimeSerial(Hour(Now()), Minute(Now()), Second(Now()) + 5)
End Sub
Sub OpenIQY(IQYName)
Dim WBN As Workbook
  Set WBN = Application.Workbooks.Add
  With WBN.Worksheets(1).QueryTables.Add(Connection:= _
    "FINDER;" & IQYName, Destination:=WBN.Worksheets(1).Range("A1"))
    .Name = "IQY"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = False
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlAllTables
    .WebFormatting = xlWebFormattingNone
    .WebPreFormattedTextToColumns = False
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
  End With
  WBN.Close SaveChanges:=True, Filename:=Replace(IQYName, ".iqy", "", , , vbTextCompare)
End Sub

To open each IQY file and save the search as an Excel file, which I could then open into workbooks and call the specific cell I needed from each of them into one master workbook. Unfortunately, when I run the above macro, the Excel Files it saves (using my IQY files) are empty.

Even if this were to work, there has to be a more efficient way.
Jaron JohnsonAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Jamie GarrochSenior Technical Consultant at BrightCarbonCommented:
Have you got one example IQY file you can share for testing unless it's pointing to a non-public server? I tried with one of the example IQY files shipped with Office14 and the new workbook file was created as expected.

This is the IQY file I tested your code with:

C:\Program Files (x86)\Microsoft Office\Office14\QUERIES\MSN MoneyCentral Investor Stock Quotes.iqy

I had to change your WBN.Close line slightly to save the file in an accessible folder but other than that, the code works on my Excel 2016 environment.

What happens if you directly open the IQY file into Excel by double clicking on it in Windows Explorer? Do you see the data you expect to see?
Jaron JohnsonAuthor Commented:
If you directly open it, I see the data I expect to see. Unfortunately, I have just discovered that the cell I need isn't consistently in the same address. It contains a unique character string, a "totals" count. I believe it says "( displaying ### of ### )" or it might just be the numbers, "(### of ###)".

What I want is that second set of numbers out of that quote. It is always in column A, but not consistently in the same cell. Is there a way to keep only that information?
Jamie GarrochSenior Technical Consultant at BrightCarbonCommented:
Is it possible to set a named range for that cell so that if it's address changes you can still reference it? If not, you could find it with something like this:

Option Explicit

' ===================================================
' Excel VBA macro to display the second value XYZ
' in text in the format "displaying ABC of XYZ"
' Written by : Jamie Garroch of YOUpresent Ltd.
' Date : 27MAR2017
' References : None
' Dependencies : uses GetDisplayingCell function
' VBE : Excel
' ===================================================
Sub DisplaySecondValue()
  Dim CellValue As String
  If Not GetDisplayingCell(CellValue) Is Nothing Then
    MsgBox "Second value is " & Right(CellValue, Len(CellValue) - InStr(1, CellValue, " of ") - 3)
    MsgBox "Couldn't find a cell containing text in the format 'displaying ### of ###'", vbCritical + vbOKOnly, "Cell Not Found"
  End If
End Sub

' ===================================================
' Excel VBA macro to find cell in column A that
' contains text in the format "displaying ### of ###"
' Written by : Jamie Garroch of YOUpresent Ltd.
' Date : 27MAR2017
' References : None
' Dependencies : None
' VBE : Excel
' ===================================================
Function GetDisplayingCell(ByRef CellValue As String) As Range
  Dim lLastRow As Long
  Dim oWS As Worksheet
  Dim lRow As Long
  Const lCol = 1 ' search in column A
  Set oWS = ActiveSheet
  lLastRow = oWS.Cells(oWS.Rows.Count, "A").End(xlUp).Row
  Debug.Print "Column " & lCol & " has " & lLastRow & " row" & IIf(lLastRow > 1, "s", "")
  For lRow = 1 To lLastRow
    With oWS.Cells(lRow, lCol)
      If .Value Like "* of *" Then
        Debug.Print "Found this text in row " & lRow & " : " & .Value
        Set GetDisplayingCell = oWS.Cells(lRow, lCol)
        CellValue = oWS.Cells(lRow, lCol)
        Set oWS = Nothing
        Exit Function
      End If
    End With
  ' Didn't find a match so return Nothing and clean up
  Set GetDisplayingCell = Nothing
  Set oWS = Nothing
End Function

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Ensure Business Longevity with As-A-Service

Using the as-a-service approach for your business model allows you to grow your revenue stream with new practice areas, without forcing you to part ways with existing clients just because they don’t fit the mold of your new service offerings.

Jaron JohnsonAuthor Commented:
So, that helped, and with a bit of a change, I am able to get the second value to show up in the pop-up box.

The values are displayed as:
( displaying 25 of 25 )

As an example.
I made the following change to specify this cell, as it initially returned a different but similar cell:
For lRow = 1 To lLastRow
    With oWS.Cells(lRow, lCol)
      If .Value Like "( displaying * of *" Then

Unfortunately, it returns:
Second value is "25 )" instead of just "25."

Also, this is a good way to track down what I want, but I really need this data exported on a large scale. What I would like to have happen is if I could run this macro, and it would delete everything except the specific data in the cell we're searching for with the above command. I have hundreds of excel documents in this format, and in the end, I need one excel document that has the searched cell data from each sheet compiled into one workbook.

The Workbooks follow an identical format. I'd need a script as mentioned above, to delete everything but the necessary data and then save the sheet, then a second script that would take every Excel file in a folder and turn it into one excel file, with the title of the excel file being in Column A, and then the data from the searched cell (which would now be the only cell in these workbooks) in Column B.

Are you able to help me with these two things? Also, thanks so much for your time so far. You've already been wildly helpful.
Jamie GarrochSenior Technical Consultant at BrightCarbonCommented:
Would be happy to help but since I believe the original question has now been answered and what you need now has evolved into something different, could you close this question and open a new one?
Jaron JohnsonAuthor Commented:
Opening new question for new issue.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.