Solved: Can I use a different (closed) workbook for a listbox rowsource? (excel '97)

[phendrena]

Hi,

I currently have the following code which populates a userform with data based on the what is held in a worksheet within the current workbook.

Is it possible to change the code below to get the data from a different (closed) workbook/sheet?

Private Sub ThisMonth()
Dim dtNow As Date
Dim dtToday As Long
dtNow = Now
dtToday = DatePart("m", dtNow)
With Me
Select Case dtToday

Case 1: .lbxResults.RowSource = ("Support!JanRota")
Case 2: .lbxResults.RowSource = ("Support!FebRota")
Case 3: .lbxResults.RowSource = ("Support!MarRota")
Case 4: .lbxResults.RowSource = ("Support!AprRota")
Case 5: .lbxResults.RowSource = ("Support!MayRota")
Case 6: .lbxResults.RowSource = ("Support!JunRota")
Case 7: .lbxResults.RowSource = ("Support!JulRota")
Case 8: .lbxResults.RowSource = ("Support!AugRota")
Case 9: .lbxResults.RowSource = ("Support!SepRota")
Case 10: .lbxResults.RowSource = ("Support!OctRota")
Case 11: .lbxResults.RowSource = ("Support!NovRota")
Case 12: .lbxResults.RowSource = ("Support!DecRota")
End Select
End With
End Sub

Thanks,

[p45cal]

While I doubt that vba code can gain access to data in cells in a closed workbook easily, a formula on a worksheet can. So one way would be to have a sheet in your open workbook dedicated to being a copy (value-wise) of a sheet in a closed workbook; the formulae would be of the ilk:
='C:\a folder\another folder\My Documents\[ClosedBook.xls]Sheet1'!A1
in cell A1, copied across and down as far as you need.
The trouble is, I'm not sure how you'd pick up named ranges.. unless the named ranges are all a constant size, in which case you could add those names yourself to that duplicate sheet.

Not very elegant, I know, but it might do the job for you.
By the way, I'm working with XL2003.

[rbrhodes]

Hi,

Here's a bit from Ron's site: http://www.rondebruin.nl/ado.htm

I've incorporated one of his examples with this snippet of code:


Sub GetMe()
Dim dtNow As Date
Dim Dst As String
Dim Pth As String
Dim Fil As String
Dim Sht As String
Dim Rng As String
Dim dtToday As Long

dtNow = Now
dtToday = DatePart("m", dtNow)

'//For Function call

'Path and file
Pth = "C:\Users\dr\Documents\Book2.xls"
'Sheet Name (Leave blank if retrieving Workbook level named range)
Sht = ""
'Named range to retrieve
Rng = "JulRota"
'Where to put it in this sheet
Dst = Sheets("Support").Range("JulRota")

'//End

With Me
Select Case dtToday

'July
Case 7

'//Call Ron's ADO Function
GetData Pth, Sht, Rng, Dst, False, False

.lbxResults.RowSource = ("Support!JulRota")

End Select
End With
End Sub



And here's the Example I used. It may look daunting (it is) but all you really have to do is write the string info in the sub above and call the function. At least it worked fine for me!

I also wrote a simple one but it only calls 1 cell at a time and doesn't seem to like named ranges (yet).


Option Explicit
Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long
' Create the connection string.
If Header = False Then
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=No"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=No"";"
End If
Else
If Val(Application.Version) < 12 Then
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes"";"
Else
szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & SourceFile & ";" & _
"Extended Properties=""Excel 12.0;HDR=Yes"";"
End If
End If
If SourceSheet = "" Then
' workbook level name
szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
' worksheet level name or range
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If
On Error GoTo SomethingWrong
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
' Check to make sure we received data and copy the data
If Not rsData.EOF Then
If Header = False Then
TargetRange.Cells(1, 1).CopyFromRecordset rsData
Else
'Add the header cell in each column if the last argument is True
If UseHeaderRow Then
For lCount = 0 To rsData.Fields.Count - 1
TargetRange.Cells(1, 1 + lCount).Value = _
rsData.Fields(lCount).Name
Next lCount
TargetRange.Cells(2, 1).CopyFromRecordset rsData
Else
TargetRange.Cells(1, 1).CopyFromRecordset rsData
End If
End If
Else
MsgBox "No records returned from : " & SourceFile, vbCritical
End If
' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub
SomethingWrong:
MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
vbExclamation, "Error"
On Error GoTo 0
End Sub

[phendrena]

Nicely done. Thank you :)