Getting data from a closed wbook

[Geoff K]

Hi

My grateful thanks - the GetArrayLastDataRow method works now, UsedRange
flaws or not. <g> Excellent stuff.

For the avoidance of doubt due to the number of varaitions I think it might
be useful to others perhaps if you were to post the finished code?.

However one thing remains - wsheet names:
Because wbks are closed I do not know the sheet name and your solution uses
"Sheet1" in the SQL but names are changed from the default albeit
occasionally.

I trap this error currently but it would be good to have avoid this issue.

I've recently been evaluating the conversion of my application to Delphi and
noted it has a very useful function called "GetTableNames". This will read
wsheet names and easily overcomes the renaming of sheets issue as far as the
SQL query is concerned.

Are you aware of a way to do this in VBA?

Geoff

 

[Bart Smissaert]

Hi

My grateful thanks - the GetArrayLastDataRow method works now, UsedRange
flaws or not. <g>  Excellent stuff.

For the avoidance of doubt due to the number of varaitions I think it might
be useful to others perhaps if you were to post the finished code?.

However one thing remains - wsheet names:
Because wbks are closed I do not know the sheet name and your solution uses
"Sheet1" in the SQL but names are changed from the default albeit
occasionally.

I trap this error currently but it would be good to have avoid this issue..

I've recently been evaluating the conversion of my application to Delphi and
noted it has a very useful function called "GetTableNames".  This will read
wsheet names and easily overcomes the renaming of sheets issue as far as the
SQL query is concerned.

Are you aware of a way to do this in VBA?

Geoff

Here is a neat way to get the sheet names of a closed workbook.
Closed is relevant here as obviously it can be done in a much simpler
way
if the wb is open.
Note that this code works on the BIFF Excel file data, so it is very
fast.

Sub TestGetWBSheetNames()

Dim arr

arr = GetWBSheetNames("C:\Test.xls")

Range(Cells(1), Cells(UBound(arr), 2)) = arr

End Sub

Function GetWBSheetNames(sFullName As String, _
Optional bWorksheetsOnly As Boolean = False,
_
Optional bSheetTypeAsString As Boolean =
True) As Variant


'--------------------------------------------------------------------
'Returns a 1-based 2-D array
'showing the sheet names in column 1 of the array
'and the sheet type in column 2 of the array
'0 = WorkSheet (dialog sheet will be 0 as well)
'2 = ChartSheet
'if bWorksheetsOnly = True it will only look at worksheets
'if bSheetTypeAsString = True it will show the sheet type as a
string

'--------------------------------------------------------------------

Dim i As Long
Dim aByt() As Byte
Dim iTyp As Integer
Dim lHnd As Long
Dim lLen As Long
Dim lPos1 As Long
Dim lPos2 As Long
Dim sTxt As String
Dim sTyp As String
Dim cRes As Collection
Dim arr

Const IDboundsheet = &H85 '133
Const BuffSize = &H400 '1024

Set cRes = New Collection
ReDim aByt(0 To BuffSize)

lLen = FileLen(sFullName)
lHnd = FreeFile

Open sFullName For Binary Access Read As lHnd Len = BuffSize

Do
lPos1 = lPos1 + BuffSize - 1
Get lHnd, lPos1, aByt
lPos2 = InStrB(aByt, ChrB(IDboundsheet))
Loop While lPos2 = 0 And lPos1 < lLen

Do While lPos2 > 0
lPos1 = lPos1 + lPos2 - 1
Get lHnd, lPos1, aByt
sTxt = Mid(StrConv(aByt, vbUnicode), 13, aByt(10))
iTyp = aByt(9)

If bSheetTypeAsString = True Then
If iTyp = 0 Then
sTyp = "WorkSheet"
Else
sTyp = "ChartSheet"
End If
If bWorksheetsOnly = True Then
If iTyp = 0 Then
cRes.Add Array(sTxt, sTyp), sTxt
End If
Else
cRes.Add Array(sTxt, sTyp), sTxt
End If
Else
If bWorksheetsOnly = True Then
If iTyp = 0 Then
cRes.Add Array(sTxt, iTyp), sTxt
End If
Else
cRes.Add Array(sTxt, iTyp), sTxt
End If
End If

If aByt(aByt(2) + 4) <> IDboundsheet Then
lPos2 = 0
Else
lPos2 = InStrB(4, aByt, ChrB(&H85))
End If
Loop

Close lHnd

'transfer the collection to an array
'-----------------------------------
ReDim arr(1 To cRes.Count, 1 To 2)

For i = 1 To cRes.Count
arr(i, 1) = cRes.Item(i)(0)
arr(i, 2) = cRes.Item(i)(1)
Next i

GetWBSheetNames = arr

End Function



RBS



"Geoff K" <GeoffK@discussions

 

[Geoff K]

Hi
I have tested the sheet name finder and found it works too though I have a
little concern about wbooks with wsheet linking formula such as
=MATCH("AAA",'C:\Path\[File.xls]Sheet1'!A:A) etc..
But at the moment I am happy to run with it and time will tell if the
anomalies were one offs.

So, once again many thanks for your help.

Geoff

 

[RB Smissaert]

Try this adapted code to handle sheets with faulty links.
Not sure it will always work and maybe somebody who knows better
about BIFF could come in here.

Function GetWBSheetNames(sFullName As String, _
Optional bWorksheetsOnly As Boolean = False, _
Optional bSheetTypeAsString As Boolean = True) As
Variant

'--------------------------------------------------------------------
'Returns a 1-based 2-D array
'showing the sheet names in column 1 of the array
'and the sheet type in column 2 of the array
'0 = WorkSheet (dialog sheet will be 0 as well)
'2 = ChartSheet
'if bWorksheetsOnly = True it will only look at worksheets
'if bSheetTypeAsString = True it will show the sheet type as a string
'--------------------------------------------------------------------

Dim i As Long
Dim aByt() As Byte
Dim iTyp As Integer
Dim lHnd As Long
Dim lLen As Long
Dim lPos1 As Long
Dim lPos2 As Long
Dim sTxt As String
Dim sTyp As String
Dim cRes As Collection
Dim arr
Dim lPosDots As Long
Dim lPosChr1 As Long

Const IDboundsheet = &H85 '133
Const BuffSize = &H400 '1024

If bFileExists(sFullName) = False Then
Exit Function 'so no array returned
End If

Set cRes = New Collection
ReDim aByt(0 To BuffSize)

lLen = FileLen(sFullName)
lHnd = FreeFile

Open sFullName For Binary Access Read As lHnd Len = BuffSize

Do
lPos1 = lPos1 + BuffSize - 1
Get lHnd, lPos1, aByt
lPos2 = InStrB(aByt, ChrB(IDboundsheet))
Loop While lPos2 = 0 And lPos1 < lLen

Do While lPos2 > 0
lPos1 = lPos1 + lPos2 - 1
Get lHnd, lPos1, aByt
sTxt = Mid(StrConv(aByt, vbUnicode), 13, aByt(10))

'this is to handle a sheet with faulty links
'there probably are more situations to handle here
'----------------------------------------------------------------
lPosDots = InStr(1, sTxt, Chr(133), vbBinaryCompare)
If lPosDots > 0 Then
lPosDots = InStr(lPosDots + 1, sTxt, Chr(133), vbBinaryCompare)
lPosChr1 = InStrRev(sTxt, Chr(0), lPosDots, vbBinaryCompare)
sTxt = Mid$(sTxt, lPosChr1 + 1, (lPosDots - lPosChr1) - 1)
End If
'----------------------------------------------------------------

iTyp = aByt(9)

If bSheetTypeAsString = True Then
'iTyp > 2 is for the above faulty links
'--------------------------------------
If iTyp = 0 Or iTyp > 2 Then
sTyp = "WorkSheet"
Else
sTyp = "ChartSheet"
End If
If bWorksheetsOnly = True Then
If iTyp = 0 Then
cRes.Add Array(sTxt, sTyp), sTxt
End If
Else
cRes.Add Array(sTxt, sTyp), sTxt
End If
Else
If bWorksheetsOnly = True Then
If iTyp = 0 Then
cRes.Add Array(sTxt, iTyp), sTxt
End If
Else
cRes.Add Array(sTxt, iTyp), sTxt
End If
End If

If aByt(aByt(2) + 4) <> IDboundsheet Then
lPos2 = 0
Else
lPos2 = InStrB(4, aByt, ChrB(&H85))
End If
Loop

Close lHnd

'transfer the collection to an array
'-----------------------------------
ReDim arr(1 To cRes.Count, 1 To 2)

For i = 1 To cRes.Count
arr(i, 1) = cRes.Item(i)(0)
arr(i, 2) = cRes.Item(i)(1)
Next i

GetWBSheetNames = arr

End Function


RBS

Hi
I have tested the sheet name finder and found it works too though I have a
little concern about wbooks with wsheet linking formula such as
=MATCH("AAA",'C:\Path\[File.xls]Sheet1'!A:A) etc..
But at the moment I am happy to run with it and time will tell if the
anomalies were one offs.

So, once again many thanks for your help.

Geoff

 

[RB Smissaert]

Found this code from Rob Bovey that gets the Workbook names with ADO and it
doesn't fail when there are links to non-existing workbooks.
It is slower than accessing the BIFF data, but a lot simpler and it does the
job.

Sub GetClosedSheetNames1(ByRef szFullName As String, _
aszSheetList() As String)

'Code written by Rob Bovey 05/13/05
'Requires reference to:
'Microsoft ActiveX Data Object X.X Library

Dim bIsWorksheet As Boolean
Dim objConnection As ADODB.Connection
Dim rsData As ADODB.Recordset
Dim lIndex As Long
Dim szConnect As String
Dim szSheetName As String

If Right(szFullName, 3) <> "xls" Then
ReDim aszSheetList(1)
aszSheetList(1) = ""
Exit Sub
End If

Erase aszSheetList()
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & szFullName & ";" & _
"Extended Properties=Excel 8.0;"

Set objConnection = New ADODB.Connection
objConnection.Open szConnect
Set rsData = objConnection.OpenSchema(adSchemaTables)

lIndex = 1

Do While Not rsData.EOF
bIsWorksheet = False
szSheetName = rsData.Fields("TABLE_NAME").Value
If Right$(szSheetName, 1) = "$" Then
''' This is a simple sheet name. Remove the trailing "$" and continue.
szSheetName = Left$(szSheetName, Len(szSheetName) - 1)
bIsWorksheet = True
ElseIf Right$(szSheetName, 2) = "$'" Then
''' This is a sheet name with spaces and/or special characters.
''' Remove the right "&'" characters.
szSheetName = Left$(szSheetName, Len(szSheetName) - 2)
''' Remove the left single quote character.
szSheetName = Right$(szSheetName, Len(szSheetName) - 1)
''' Embedded single quotes in the sheet name will be doubled up.
''' Replace any doubled single quotes with one single quote.
szSheetName = Replace$(szSheetName, "''", "'")
bIsWorksheet = True
End If
If bIsWorksheet Then
''' Load the processed sheet name into the array.
ReDim Preserve aszSheetList(1 To lIndex)
aszSheetList(lIndex) = szSheetName
lIndex = lIndex + 1
End If
rsData.MoveNext
Loop

rsData.Close
Set rsData = Nothing
objConnection.Close
Set objConnection = Nothing

End Sub

Sub TestMethod1()

Dim strArr() As String
Dim i As Long

GetClosedSheetNames1 "C:\Test.xls", strArr

For i = LBound(strArr) To UBound(strArr)
MsgBox strArr(i)
Next i

End Sub


RBS

Try this adapted code to handle sheets with faulty links.
Not sure it will always work and maybe somebody who knows better
about BIFF could come in here.

Function GetWBSheetNames(sFullName As String, _
Optional bWorksheetsOnly As Boolean = False, _
Optional bSheetTypeAsString As Boolean = True) As
Variant

'--------------------------------------------------------------------
'Returns a 1-based 2-D array
'showing the sheet names in column 1 of the array
'and the sheet type in column 2 of the array
'0 = WorkSheet (dialog sheet will be 0 as well)
'2 = ChartSheet
'if bWorksheetsOnly = True it will only look at worksheets
'if bSheetTypeAsString = True it will show the sheet type as a string
'--------------------------------------------------------------------

Dim i As Long
Dim aByt() As Byte
Dim iTyp As Integer
Dim lHnd As Long
Dim lLen As Long
Dim lPos1 As Long
Dim lPos2 As Long
Dim sTxt As String
Dim sTyp As String
Dim cRes As Collection
Dim arr
Dim lPosDots As Long
Dim lPosChr1 As Long

Const IDboundsheet = &H85 '133
Const BuffSize = &H400 '1024

If bFileExists(sFullName) = False Then
Exit Function 'so no array returned
End If

Set cRes = New Collection
ReDim aByt(0 To BuffSize)

lLen = FileLen(sFullName)
lHnd = FreeFile

Open sFullName For Binary Access Read As lHnd Len = BuffSize

Do
lPos1 = lPos1 + BuffSize - 1
Get lHnd, lPos1, aByt
lPos2 = InStrB(aByt, ChrB(IDboundsheet))
Loop While lPos2 = 0 And lPos1 < lLen

Do While lPos2 > 0
lPos1 = lPos1 + lPos2 - 1
Get lHnd, lPos1, aByt
sTxt = Mid(StrConv(aByt, vbUnicode), 13, aByt(10))

'this is to handle a sheet with faulty links
'there probably are more situations to handle here
'----------------------------------------------------------------
lPosDots = InStr(1, sTxt, Chr(133), vbBinaryCompare)
If lPosDots > 0 Then
lPosDots = InStr(lPosDots + 1, sTxt, Chr(133), vbBinaryCompare)
lPosChr1 = InStrRev(sTxt, Chr(0), lPosDots, vbBinaryCompare)
sTxt = Mid$(sTxt, lPosChr1 + 1, (lPosDots - lPosChr1) - 1)
End If
'----------------------------------------------------------------

iTyp = aByt(9)

If bSheetTypeAsString = True Then
'iTyp > 2 is for the above faulty links
'--------------------------------------
If iTyp = 0 Or iTyp > 2 Then
sTyp = "WorkSheet"
Else
sTyp = "ChartSheet"
End If
If bWorksheetsOnly = True Then
If iTyp = 0 Then
cRes.Add Array(sTxt, sTyp), sTxt
End If
Else
cRes.Add Array(sTxt, sTyp), sTxt
End If
Else
If bWorksheetsOnly = True Then
If iTyp = 0 Then
cRes.Add Array(sTxt, iTyp), sTxt
End If
Else
cRes.Add Array(sTxt, iTyp), sTxt
End If
End If

If aByt(aByt(2) + 4) <> IDboundsheet Then
lPos2 = 0
Else
lPos2 = InStrB(4, aByt, ChrB(&H85))
End If
Loop

Close lHnd

'transfer the collection to an array
'-----------------------------------
ReDim arr(1 To cRes.Count, 1 To 2)

For i = 1 To cRes.Count
arr(i, 1) = cRes.Item(i)(0)
arr(i, 2) = cRes.Item(i)(1)
Next i

GetWBSheetNames = arr

End Function


RBS

Hi
I have tested the sheet name finder and found it works too though I have
a
little concern about wbooks with wsheet linking formula such as
=MATCH("AAA",'C:\Path\[File.xls]Sheet1'!A:A) etc..
But at the moment I am happy to run with it and time will tell if the
anomalies were one offs.

So, once again many thanks for your help.

Geoff

 

[Geoff K]

That seems to overcome the issues with links. I've thrown a lot my 'anomaly'
wbs at it and it does the job so far.

On to the next one....

Thank you.

Geoff

Found this code from Rob Bovey that gets the Workbook names with ADO and it
doesn't fail when there are links to non-existing workbooks.
It is slower than accessing the BIFF data, but a lot simpler and it does the
job.

Sub GetClosedSheetNames1(ByRef szFullName As String, _
aszSheetList() As String)

'Code written by Rob Bovey 05/13/05
'Requires reference to:
'Microsoft ActiveX Data Object X.X Library

Dim bIsWorksheet As Boolean
Dim objConnection As ADODB.Connection
Dim rsData As ADODB.Recordset
Dim lIndex As Long
Dim szConnect As String
Dim szSheetName As String

If Right(szFullName, 3) <> "xls" Then
ReDim aszSheetList(1)
aszSheetList(1) = ""
Exit Sub
End If

Erase aszSheetList()
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & szFullName & ";" & _
"Extended Properties=Excel 8.0;"

Set objConnection = New ADODB.Connection
objConnection.Open szConnect
Set rsData = objConnection.OpenSchema(adSchemaTables)

lIndex = 1

Do While Not rsData.EOF
bIsWorksheet = False
szSheetName = rsData.Fields("TABLE_NAME").Value
If Right$(szSheetName, 1) = "$" Then
''' This is a simple sheet name. Remove the trailing "$" and continue.
szSheetName = Left$(szSheetName, Len(szSheetName) - 1)
bIsWorksheet = True
ElseIf Right$(szSheetName, 2) = "$'" Then
''' This is a sheet name with spaces and/or special characters.
''' Remove the right "&'" characters.
szSheetName = Left$(szSheetName, Len(szSheetName) - 2)
''' Remove the left single quote character.
szSheetName = Right$(szSheetName, Len(szSheetName) - 1)
''' Embedded single quotes in the sheet name will be doubled up.
''' Replace any doubled single quotes with one single quote.
szSheetName = Replace$(szSheetName, "''", "'")
bIsWorksheet = True
End If
If bIsWorksheet Then
''' Load the processed sheet name into the array.
ReDim Preserve aszSheetList(1 To lIndex)
aszSheetList(lIndex) = szSheetName
lIndex = lIndex + 1
End If
rsData.MoveNext
Loop

rsData.Close
Set rsData = Nothing
objConnection.Close
Set objConnection = Nothing

End Sub

Sub TestMethod1()

Dim strArr() As String
Dim i As Long

GetClosedSheetNames1 "C:\Test.xls", strArr

For i = LBound(strArr) To UBound(strArr)
MsgBox strArr(i)
Next i

End Sub


RBS

Try this adapted code to handle sheets with faulty links.
Not sure it will always work and maybe somebody who knows better
about BIFF could come in here.

Function GetWBSheetNames(sFullName As String, _
Optional bWorksheetsOnly As Boolean = False, _
Optional bSheetTypeAsString As Boolean = True) As
Variant

'--------------------------------------------------------------------
'Returns a 1-based 2-D array
'showing the sheet names in column 1 of the array
'and the sheet type in column 2 of the array
'0 = WorkSheet (dialog sheet will be 0 as well)
'2 = ChartSheet
'if bWorksheetsOnly = True it will only look at worksheets
'if bSheetTypeAsString = True it will show the sheet type as a string
'--------------------------------------------------------------------

Dim i As Long
Dim aByt() As Byte
Dim iTyp As Integer
Dim lHnd As Long
Dim lLen As Long
Dim lPos1 As Long
Dim lPos2 As Long
Dim sTxt As String
Dim sTyp As String
Dim cRes As Collection
Dim arr
Dim lPosDots As Long
Dim lPosChr1 As Long

Const IDboundsheet = &H85 '133
Const BuffSize = &H400 '1024

If bFileExists(sFullName) = False Then
Exit Function 'so no array returned
End If

Set cRes = New Collection
ReDim aByt(0 To BuffSize)

lLen = FileLen(sFullName)
lHnd = FreeFile

Open sFullName For Binary Access Read As lHnd Len = BuffSize

Do
lPos1 = lPos1 + BuffSize - 1
Get lHnd, lPos1, aByt
lPos2 = InStrB(aByt, ChrB(IDboundsheet))
Loop While lPos2 = 0 And lPos1 < lLen

Do While lPos2 > 0
lPos1 = lPos1 + lPos2 - 1
Get lHnd, lPos1, aByt
sTxt = Mid(StrConv(aByt, vbUnicode), 13, aByt(10))

'this is to handle a sheet with faulty links
'there probably are more situations to handle here
'----------------------------------------------------------------
lPosDots = InStr(1, sTxt, Chr(133), vbBinaryCompare)
If lPosDots > 0 Then
lPosDots = InStr(lPosDots + 1, sTxt, Chr(133), vbBinaryCompare)
lPosChr1 = InStrRev(sTxt, Chr(0), lPosDots, vbBinaryCompare)
sTxt = Mid$(sTxt, lPosChr1 + 1, (lPosDots - lPosChr1) - 1)
End If
'----------------------------------------------------------------

iTyp = aByt(9)

If bSheetTypeAsString = True Then
'iTyp > 2 is for the above faulty links
'--------------------------------------
If iTyp = 0 Or iTyp > 2 Then
sTyp = "WorkSheet"
Else
sTyp = "ChartSheet"
End If
If bWorksheetsOnly = True Then
If iTyp = 0 Then
cRes.Add Array(sTxt, sTyp), sTxt
End If
Else
cRes.Add Array(sTxt, sTyp), sTxt
End If
Else
If bWorksheetsOnly = True Then
If iTyp = 0 Then
cRes.Add Array(sTxt, iTyp), sTxt
End If
Else
cRes.Add Array(sTxt, iTyp), sTxt
End If
End If

If aByt(aByt(2) + 4) <> IDboundsheet Then
lPos2 = 0
Else
lPos2 = InStrB(4, aByt, ChrB(&H85))
End If
Loop

Close lHnd

'transfer the collection to an array
'-----------------------------------
ReDim arr(1 To cRes.Count, 1 To 2)

For i = 1 To cRes.Count
arr(i, 1) = cRes.Item(i)(0)
arr(i, 2) = cRes.Item(i)(1)
Next i

GetWBSheetNames = arr

End Function


RBS

Hi
I have tested the sheet name finder and found it works too though I have
a
little concern about wbooks with wsheet linking formula such as
=MATCH("AAA",'C:\Path\[File.xls]Sheet1'!A:A) etc..
But at the moment I am happy to run with it and time will tell if the
anomalies were one offs.

So, once again many thanks for your help.

Geoff