How to do the same thing with xls file?

Digitborn.com

Active Member
Joined
Apr 3, 2007
Messages
353
Option Explicit
'#########################################################
'# #
'# References need to be set in the VBE to the following #
'# reference libraries:- #
'# Microsoft ActiveX Data Objects 2.5 or > Library #
'# #
'#########################################################

'You may also need to amend the path to Northwind Database in the connection string below

Const stCon As String = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=D:\a\Excel 2003\archive\Forum\Northwind.mdb;" & _
"Persist Security Info=False"


Private Sub cmdClose_Click()
'close the form
Unload Me
End Sub

Private Sub chkYr_Click()
'This is where you can add a filter by the year
Dim stSQL As String
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim vaData As Variant

'Just select the Distinct Years from Orders Table to load into Year Combobox
stSQL = "SELECT DISTINCT DatePart(""yyyy"",[OrderDate]) FROM ORDERS;"

If chkYr.Value = True Then
'if the year filter checkbox is checked
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
cnt.ConnectionString = stCon
With cnt
.CursorLocation = adUseClient 'Necesary for creating disconnected recordset.
.Open stCon 'Open connection.
'Execute the SQL statement.
Set rst = .Execute(stSQL)
End With
With rst
Set .ActiveConnection = Nothing 'Disconnect the recordset.
'Populate the array with the whole recordset.
vaData = .GetRows
End With
'Close the connection.
cnt.Close
With Me
With .cmbYr
.Clear
'load the query result into combobox
.List = Application.Transpose(vaData)
.ListIndex = -1
End With
End With
Else
With Me
With .cmbYr
.Clear
End With
End With
End If
End Sub

Private Sub cmdQuery_Click()
'run query to find records
Dim stParam As String, stParam2 As String
Dim stSQL As String
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim fld As ADODB.Field
Dim wsSheet As Worksheet, wbBook As Workbook
Dim i As Long, j As Long, x As Integer

'initial SQL to return all records
stSQL = "SELECT * FROM ORDERS"

'set the parameter strings
stParam = " WHERE DatePart(""yyyy"",[OrderDate]) = " & Me.cmbYr.Text
stParam2 = " ;"

'check & build variable parameters
'depending on whether checkbox ticked by user
If Me.chkYr.Value = True Then
stSQL = stSQL & stParam & stParam2
Else: stSQL = stSQL & stParam2
End If

On Error GoTo ErrHandle

Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset

Set wbBook = ThisWorkbook
Set wsSheet = ThisWorkbook.Worksheets(1)

With cnt
.ConnectionString = stCon
.Open
End With

With rst
.CursorLocation = adUseClient
.Open stSQL, cnt, adOpenStatic, adLockReadOnly
.ActiveConnection = Nothing 'Here we disconnect the recordset.
j = .Fields.Count
i = .RecordCount
End With

With wsSheet
.UsedRange.Clear
If i = 0 Then GoTo i_Err
'Write the fieldnames to the fifth row in the worksheet
For x = 0 To j - 1
.Cells(5, x + 1).Value = rst.Fields(x).Name
Next x
'Dump the data to the worksheet.
.Cells(6, 1).CopyFromRecordset rst
End With

If CBool(rst.State And adStateOpen) = True Then rst.Close
Set rst = Nothing
If CBool(cnt.State And adStateOpen) = True Then cnt.Close
Set cnt = Nothing

ExitHere:
Exit Sub

ErrHandle:
Dim cnErrors As ADODB.Errors
Dim ErrorItem As ADODB.Error
Dim stError As String

Set cnErrors = cnt.Errors

With Err
stError = stError & vbCrLf & "VBA Error # : " & CStr(.Number)
stError = stError & vbCrLf & "Generated by : " & .Source
stError = stError & vbCrLf & "Description : " & .Description
End With

For Each ErrorItem In cnErrors
With ErrorItem
stError = stError & vbCrLf & "ADO error # : " & CStr(.Number)
stError = stError & vbCrLf & "Description : " & .Description
stError = stError & vbCrLf & "Source : " & .Source
stError = stError & vbCrLf & "SQL State : " & .SqlState
End With
Next ErrorItem
MsgBox stError, vbCritical, "SystemError"
Resume ExitHere

i_Err:
MsgBox "There are no records for this Query"
GoTo ExitHere
End Sub
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
How about giving us some clue about what that code does, and what you want it to do ? Simply posting a mound of code without any comment is maybe not the best way to get help on here :)
 
Upvote 0
Thanks very much Kevlarhead. I used this link - http://www.beyondtechnology.com/geeks023.shtml and get to the point where I retrieve data from a closed xls file and do UserForm1.ComboBox1.AddItem. This is what I wanted. I have 2 small problems now:

1. If the column have numbers and text it adds in ComboBox1 only numbers or only text data. How can I add all values?

2. With this ADO & Recordset method first I add the data to the opened Workbook.Worksheet and then I add it to the UserForm1.ComboBox1 with For Each...Next statement. Is it possible to add directly the items into the UserForm1.ComboBox1?

Here's the code I use:

Private Sub GetData(SrcFile$, SrcSheet$, SrcRange$, rTgt As Range, fHdr As Boolean)
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim a&
Dim cnct$
' Initialize a variable for the connection string
cnct$ = "DRIVER={Microsoft Excel Driver (*.xls)}; DBQ= " & SrcFile$
' Initialize connection object
Set cn = New ADODB.Connection

With cn
' Open the database connection
.Open cnct$
' Execute the query
Set rs = .Execute("[" & SrcSheet$ & "$" & SrcRange$ & "]")
End With

' Initialize a variable for the upper left cell of the target range
Set rTgt = rTgt.Cells(1)

With rs
' Determine whether to get the field header
If fHdr Then
' Loop across the fields
For a& = 0 To .Fields.Count - 1
' Get the field names
rTgt.Offset(0, a&).Value = .Fields(a&).Name
Next a&
' Advance the target pointer to the next available row in the
' destination worksheet
Set rTgt = rTgt.Offset(1, 0)
End If
' Apply the CopyFromRecordset method
rTgt.CopyFromRecordset rs
' Close the RecordSet
.Close
End With

' Close the database connection
cn.Close
' Recover memory from object variables
Set cn = Nothing
Set rs = Nothing
End Sub

Sub a()
Dim thing As Range

Call GetData("D:\a\Excel 2003\archive\Forum\testBook1.xls", _
"Table", "A1:A65536", Sheet1.Cells(1, 1), True)

UserForm1.ComboBox1.Clear
With Workbooks("Book4.xls").Worksheets("qqq")
For Each thing In .Range("A1", .Range("A65536").End(xlUp)).SpecialCells(xlCellTypeConstants)
If thing.Value <> "" Then
UserForm1.ComboBox1.AddItem thing.Value
End If
Next
End With

UserForm1.Show
End Sub

p.s. The columns are in General format. I tried to format the both columns into Text but all items aren't adding in the ComboBox1.
 
Upvote 0
The problem 2 is in fact very big one because if I use a function which opens/reads, additems to ComboBox/closes the workbook the process is 10-15 times faster than ADO Recordset (the above message example). This function is:

Public Sub Read_Workbook_Data()
workbookFile = "D:\a\mProject\NatFun2006_ok.xls"
Set wbData = Workbooks.Open(workbookFile, , True)
Set rngData = wbData.Worksheets("ParFun")

With wbData.Worksheets("ParFun")
For Each thing In .Range("C2", .Range("C65536").End(xlUp)).SpecialCells(xlCellTypeConstants)
If thing.Value <> "" Then
UserForm1.ComboBox1P1.AddItem thing.Value
End If
Next
End With

wbData.Close False
End Sub
----

ADO is taking 20-30 seconds, the Read_Workbook_Data takes 2-3 seconds. Thought this opening/closing workbooks thing is really annoying although Application.ScreenUpdating = False. The strange thing which really shot me is the very slow ADO processing data! Everywhere is written how fast is using ADO.

p.s. I use Excel 2003, Visual Basic 6.5, Pentium IV 3.2 GHz, 2 GB Kingstone RAM, WinXP Prof
 
Last edited:
Upvote 0
1. If the column have numbers and text it adds in ComboBox1 only numbers or only text data. How can I add all values?

Can't be done. When you use ADO, the first 8 lines of the spreadsheet are polled for the type of data they contain, and the majority data type is adpoted for use in the spreadsheet. Data can be either number or text. To ensure all values are readable, they either have to be all number or all text. It's a pain, but that's the way it is.

As to 2... I have a 2.4Ghz Dell Machine, running Office 2002, with 1.3G RAM, and I can get 10-15 read/writes done with ADO done inside a second.
 
Last edited:
Upvote 0
I think the speed issues you're having are because you're reading cells one at a time and using CopyFromRecordset on them, which is slowing you down.

I wrote the following, and it read a list of sites I use from file and loaded them into a combobox in less than a second. See if it helps. It's a bit hard-coded. Hopefully this won't be too much of a problem.




Private Sub CommandButton1_Click()

Dim Connect As New ADODB.Connection
Dim rsResult As New ADODB.Recordset

Dim DataSource As String
Dim StrQuery As String

Dim SiteArray As Variant
Dim LoopCount As Integer

'The full drive, filepath, a filename and extension of the file you wish to read from.
DataSource = "C:\Filepath\TheFileName.xls"

'SQL Query; returns all items from the column titled 'sitecode' on the sheet called Sheet1
'The square brackets and the $ must be included to query an Excel file.
StrQuery = "SELECT SiteCode FROM [Sheet1$];"

'---------------------------------------------------------------------------
Set Connect = New ADODB.Connection 'the connection to the datasource
Set rsResult = New ADODB.Recordset 'the recordset object the results of the query are returned to

'----------------------------
With Connect
.Provider = "Microsoft.Jet.OLEDB.4.0" 'we're using the Jet engine for this
.ConnectionString = "Data Source=" & (DataSource) & "; Extended Properties=Excel 8.0;"
.Open
End With
'-----------------------------

'Open the recordset to receive the results of the query
rsResult.Open StrQuery, Connect, adOpenStatic, adLockReadOnly
'----------------------------------------------------------------------------

'Loads the contents of the recordset into the SiteArray Variant array
SiteArray = rsResult.GetRows(-1, 0)

'Kill off the connections to the datasource file
Connect.Close
Set Connect = Nothing
Set rsResult = Nothing


'Loop through the array, loading each item into the ComboBox
Do Until LoopCount > UBound(SiteArray, 2)
ComboBox1.AddItem SiteArray(0, LoopCount)
LoopCount = LoopCount + 1
Loop

End Sub
 
Last edited:
Upvote 0
Thanks very much Kevlarhead, it was really working well and it's much faster. In order to complete my task I need to solve a few more small things around this code. I'll ask you for advice about them:

1. I added 2 small pieces to the code you gave me. Do you think these pieces affect the speed of the process much and if so, is there better way? These things are at the bottom of the code:

UserForm1.ComboBox1.Clear 'thing1
Do Until LoopCount > UBound(SiteArray, 2)
If SiteArray(0, LoopCount) <> "" Then 'thing2
UserForm1.ComboBox1P1.AddItem SiteArray(0, LoopCount)
End If
LoopCount = LoopCount + 1
Loop
UserForm1.Show 'thing3

'thing2 I added because I have many empty cells which I don't want to add in ComboBox1. The structure of this Column in the workbook (Book7.xls) I read from is 28000 rows and 270 not empty which I'm adding to ComboBox1.
----------------------------------------------------------

2. I put your code in Module1 in procedure called a1()

Sub a1()
'your code
End Sub

Then I call a1() from UserForm2.CommandButton:

Private Sub CommandButton1_Click()
Call a1
End Sub

The ComboBox1 is on UserForm1 (not on UserForm2) where we load the values. I said this to explain your my next task which is a problem for me:

On UserForm1 I have Label1. I want when UserForm1.ComboBox1 changes on UserForm1.Label1.Caption = "the previous column item which corresponds to ComboBox1.Value from the workbook (Book7.xls) I read from". I previously did this with this code:

Private Sub ComboBox1_Change()
Dim thing As Range
Dim paNumber As Long

Workbooks("Book7.xls").Activate
With Worksheets("ParFun")
For Each thing In .Range("C2", .Range("C65536").End(xlUp)).SpecialCells(xlCellTypeConstants)
If thing.Value = Trim(ComboBox1.Value) Then
Label1.Caption = thing.Offset(, -1).Value
mfNumber = thing.Offset(, -1).Value
Label2.Caption = ComboBox1.Text & " " & mfNumber
Exit For
End If
Next
End With
End Sub

How can I do this with your code on ComboBox1_Change event?

3. The last problem is concerning a memory/processing issue with UserForm1 which is shown (when the items are loaded in UserForm1.ComboBox1 with your ADO SQL code) on the ActiveWorkbook. When I try to move it with the mouse it copies many UserForms1 on the background. It is slurring on the screen. I don't know how to explain this exactly :), hope you catch it ;).
If the UserForm1 is visualized on the VBA screen this is not happening. In fact nevertheless which code I use this problem is happing if the UserForm1 is appearing on the ActiveWorksheet. Do you know what's happening there? Can you understand what I mean?

I hope you understood my probs and examples. I hope it's not too long and difficult. If you need any clearance on the points I'll try to answer back shortly.
 
Upvote 0
Couldn't you use the query to only return values?
 
Upvote 0

Forum statistics

Threads
1,216,222
Messages
6,129,586
Members
449,520
Latest member
TBFrieds

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top