Home |
Search |
Today's Posts |
#41
Posted to microsoft.public.excel.programming
|
|||
|
|||
Getting data from a closed wbook
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 "Geoff K" wrote: I am now mailing the largest flawed UsedRange wbk. All real data has been replaced with similar data type. The UsedRange last cell is AF50918 and the real last cell is S98. This wbk will not run Excel4 - it just hangs. Execution is considerably slowed using other methods. Please let me know how you get on. Geoff |
#42
Posted to microsoft.public.excel.programming
|
|||
|
|||
Getting data from a closed wbook
On Oct 5, 3:53*pm, Geoff K wrote:
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 "Geoff K" wrote: I am now mailing the largest flawed UsedRange wbk. All real data has been replaced with similar data type. The UsedRange last cell is AF50918 and the real last cell is S98. This wbk will not run Excel4 - it just hangs. *Execution is considerably slowed using other methods. Please let me know how you get on. 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 |
#43
Posted to microsoft.public.excel.programming
|
|||
|
|||
Getting data from a closed wbook
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 |
#44
Posted to microsoft.public.excel.programming
|
|||
|
|||
Getting data from a closed wbook
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 "Geoff K" wrote in message ... 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 |
#45
Posted to microsoft.public.excel.programming
|
|||
|
|||
Getting data from a closed wbook
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 "RB Smissaert" wrote in message ... 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 "Geoff K" wrote in message ... 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 |
#46
Posted to microsoft.public.excel.programming
|
|||
|
|||
Getting data from a closed wbook
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 "RB Smissaert" wrote: 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 "RB Smissaert" wrote in message ... 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 "Geoff K" wrote in message ... 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Get values from 15 sheets in a Wbook | Excel Programming | |||
updating wbook from other... | Excel Programming | |||
transfering data from 2 wbook | Excel Programming | |||
transfering data value from 2 Wbook... | Excel Programming | |||
Read And Write On A Closed Wbook | Excel Programming |