Return Address of String in Closed Workbook with VBA

[Sheets Feats]

I have almost 900 workbooks that I need to mine for data. These workbooks are nearly identical, but through the years the addresses for certain info has changed. I currently have a macro (below) which works nicely that opens each WB, looks for my defined string, and returns the location. For this macro that's all I need, however it takes about 30 minutes to complete since it has to open each one.

Once I have my addresses, I use a separate macro that utilizes ExecuteExcel4Macro which pulls the info I'm ultimately looking for. This process only takes about 30 seconds since it doesn't open each WB. I have not had success using ExecuteExcel4Macro unless I have a specific cell to reference which is why it works for the second scenario and not the first.

Here's the macro I'd like to see work more efficiently. Is there any way to get around opening each WB individually? The focus of my issue is about halfway through the code:

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
End With


'variables to build unique file names and how much to repeat
strSearchFor = "Partial String To Search"
RowStart = 4
RowEnd = 883
Set wbCollector = Workbooks("WorkbookThatCollectsTheInfo.xlsm")
ColumnToFill = "L"
PathColumnOffset = -8
FileColumnOffset = -7
SheetName = "Sheet1"


Sheets(SheetName).Range(ColumnToFill & RowStart).Activate
For reps = RowStart To RowEnd


    fpath = Sheets(SheetName).Range(ColumnToFill & reps).Offset(0, PathColumnOffset).Value
    fname = Sheets(SheetName).Range(ColumnToFill & reps).Offset(0, FileColumnOffset).Value
    
'*** the focus of my issue, opening each WB to return an address ***
    Set owb = Application.Workbooks.Open(fpath & fname)
    
    Set ra = Sheets("SheetInExternalWB").Cells.Find(What:=strSearchFor, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False)
    
    If ra Is Nothing Then
        wbCollector.Sheets(SheetName).Range(ColumnToFill & reps).Value = "Not found"
        Else
        wbCollector.Sheets(SheetName).Range(ColumnToFill & reps).Value = ra.Address
    End If
    
    With owb
        .Close
    End With


Next reps


With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
End With

 

[Worf]

Welcome to the Board

This method may be faster. If a worksheet contains a huge amount of data, the string variable may complain.

Sub Main()                                              ' run me
Gdata "c:\pub\inventory.xlsx", "Sheet1", "a1:d39"
End Sub

Sub Gdata(f, sht$, Rng$)
Dim con As Object, rs As New ADODB.Recordset, sql$, mys$, pos%, c%, eostr$
sql = "SELECT * FROM [" & sht$ & "$" & Rng$ & "];"
Set con = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & _
f & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
rs.Open sql, con, 0, 1, 1
mys = rs.GetString(adClipString)
pos = InStr(mys, "bus")                                 ' search for this string
c = 0                                                   ' safety
Do
    pos = pos + 1: c = c + 1
Loop Until Mid(mys, pos, 1) = vbTab Or Mid(mys, pos, 1) = vbCr Or c > 30
eostr = pos                                             ' end of desired data
c = 0
Do                                                      ' find start of data
    pos = pos - 1: c = c + 1
Loop Until Mid(mys, pos, 1) = vbTab Or Mid(mys, pos, 1) = vbCr Or c > 30
MsgBox Mid(mys, pos, eostr - pos), 64, "Desired Data"
rs.Close
Set rs = Nothing
con.Close
Set con = Nothing
End Sub

 

[Sheets Feats]

Thank you Worf. I believe your code is trying to accomplish the task of both of my macros because it's returning the contents of the cell and not the address. I'd rather it return the address because that helps me separate my list of workbooks into different revisions that they've been saved as through the years, and I can do this before I run my other code.
Also, is there a way to turn off case sensitivity? I can get around this if need be but it would be useful.

 

[Worf]

This version is not case sensitive and informs the cell address. If the array looping proves to be slow, we can try another method.

Sub Main()                                              ' run me
Gdata "c:\pub\inventory.xlsx", "Sheet1", "a1:d39"
End Sub


Sub Gdata(f, sht$, Rng$)
Dim con As Object, rs As New ADODB.Recordset, sql$, X, i%, j%, carry_on As Boolean
sql = "SELECT * FROM [" & sht$ & "$" & Rng$ & "];"
Set con = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & _
f & ";" & "Extended Properties=""Excel 12.0;HDR=No"";"
rs.Open sql, con, 0, 1, 1
X = rs.GetRows                                                  ' transfer to array
carry_on = True
For i = LBound(X, 1) To UBound(X, 1)
    If Not carry_on Then Exit For
    For j = LBound(X, 2) To UBound(X, 2)
        If UCase(X(i, j)) Like "*BUS*" Then
            MsgBox Cells(j + 1, i + 1).Address, 64, "Desired address"
            carry_on = False
            Exit For
        End If
Next j, i
rs.Close: Set rs = Nothing
con.Close: Set con = Nothing
End Sub

 

[Sheets Feats]

My first successful run completed in 1 minute 40 seconds! Absolutely lightning fast compared to my initial code time of 20 minutes. Thank you Worf!

I can work around this but there is something your first code was able to do that the second cannot, which is to be able to search with a partial string. In most cases it's simply due do a colon, the difference between finding "value" and "value:". For now I'm just going to narrow my loop to cells that don't return a value and then change my search string to include a colon, and that will work great for the foreseeable future.

 

[Sheets Feats]

Oh and also, I got an error when it came across a workbook that was open by someone else on the network. That would definitely be nice to fix.

 

[Worf]

If UCase(X(i, j)) Like "*BUS*" Then

• Partial match is working for me. Did you use the asterisks as shown above? I am assuming you are searching strings. It is always possible to convert numbers into strings. Also, type the string in uppercase.
• What line throws the open workbook error? What is the error number and message?

 

[Sheets Feats]

You got it! I wasn't using the wildcard. I noticed the uppercase thing though and replaced the "*BUS*" with a variable so that's hasn't been an issue, ie:

searchstring = UCase("search me")
....
If UCase(X(i, j)) Like searchstring Then

The error is Run-time error '9': Subscript out of range. I replaced your MsgBox of the return value to a variable that can be placed in the workbook, so:

[COLOR=#333333]MsgBox Cells(j + 1, i + 1).Address, 64, "Desired address"
[/COLOR]
'turns to something like

[COLOR=#333333]valueiwant [/COLOR]= Cells(j + 1, i + 1).Address
[COLOR=#333333]Sheets(varSheetName).Range(varCell).Value = valueiwant 'this is the line where debug stops[/COLOR]

It's worth noting that the entirety of the ADODB connection is now within a For-Next loop.

But really, this hasn't been a big issue. If someone's in a book then I flag it and loop my code around it. Effectively, especially now knowing I was missing the wildcard, this works exactly how I'd like it to work.

 

[Worf]

I am not seeing the entire code, but maybe the issue is not an open workbook.

After the X array is populated, we do not need the network file anymore.
Where does varSheetName come from?
When the code stops, hover the mouse over the three variables on that line to get a screen tip and tell me which one is the culprit.
See picture below.

<strike></strike>

<strike></strike>