I have a quick question.
I have an Excel sheet.. which contains descriptions of certain items:For example:
1) Awesome mirror
2) Another Awesome mirror
3) beautiful table
4) Pretty beautiful lovely sofa
5) one more mirror
and so on...
So lets say, I want to place all the mirrors together, all the tables together...
and so on... so basically something which can return me all the instances which contain the word "mirror".
Any ideas on how to solve about this?
You could use a formula solution as below:
=SUM(COUNTIF(A1,"*"&{"table","mirror","sofa"}&"*")*{1,100,1000})
will give
table a score of 1
mirror a score of 100
sofa a score of 1000
allowing an easy numerical sort.
If it was possible that a cell could contain both mirror and sofa then it would get a score of 101. In this case you may either:
be happy to have a separate list of multi-matches
I could further adapt the formula if you can provide how you would like a multi-match handled.
Another possibility is ADO. This will return two rows when an item occurs twice. It would also be possible to play around with another column in ToFind that allowed a Not Like : Like '%' & [ToFind] & '%' And Not Like '%' & [NotToFind] & '%'
Input
Result
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String
Dim i As Integer, j As Integer
''This is not the best way to refer to the workbook
''you want, but it is very convenient for notes
''It is probably best to use the name of the workbook.
strFile = ActiveWorkbook.FullName
''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
''[ToFind] is a named range, but it does not have to be.
strSQL = "SELECT DISTINCT [List], [ToFind] " _
& "FROM [Sheet1$A:A] a, " _
& "[ToFind] b " _
& "WHERE List Like '%' & [ToFind] & '%'"
rs.Open strSQL, cn, 3, 3
''Pick a suitable empty worksheet for the results
Worksheets("Sheet2").Cells(2, 1).CopyFromRecordset rs
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
If you just want to show all "Tables" in your list, why not use the Autofilter end type Table in the search field. This way only items with the word "Table" in the string will show up. All other rows will be hidden.
Regards,
Robert
You can create a new column and use this UDF:
Function WhatIsIt(LineItem As Range, AllThings As Range) As String
Dim rv As String, c As Range
Dim v As String, thing As String
v = UCase(LineItem.Cells(1).Value)
rv = ""
If Len(v) > 0 Then
For Each c In AllThings.Cells
thing = c.Value
If Len(thing) > 0 And InStr(v, UCase(thing)) > 0 Then
rv = thing
Exit For
End If
Next c
End If
WhatIsIt = rv
End Function
"AllThings" is a range with a list of what you want to look for. Make sure to put longer terms first: ie. "sofa table" should come before "sofa" or "table".
Note it could use some improvement: it will also return matches when a term is only part of another word in the item description.
Related
I hope someone can give me some direction using the ADODB methods to accomplish my goal.
Brief explanation:
Currently I have code in Outlook VBA that searches an email. If the email passes criteria the Outlook macro opens an Excel workbook, loops through column A to see if an ID number exists. If it does it updates other columns (1 or more columns), if not it creates a new row and writes data into Columns A-C for that row. Then saves and closes the workbook.
I want to speed up the process and the limiting factor is opening the excel workbook (located on a share drive). I have used a simple ADODB macro to read data in another workbook and have seen the speed increases possible. I want to implement that here.
I have been able to establish connection to the workbook from Outlook and place data into a recordset. BUT I don't know how to "loop" through the first column to see if the ID exists yet or not, and further more how to write data into the columns in the workbook (UPDATE SQL command?).
ExcelConnection Code:
Public Sub ExcelConnect(msg As Outlook.MailItem, LType As String)
Dim lngrow As Long
Dim SourceFile As Variant 'used
Dim SourceSheet As String 'used
Dim SourceRange As String 'used
SourceFile = "T:\Capstone Proj\TimeStampsOnlyTest.xlsx"
SourceSheet = "Timestamps"
SourceRange = "A2:F500"
Dim rsCon As Object 'used
Dim rsData As Object 'used
Dim szConnect As String ' used
Dim szSQL As String ' used
Dim lCount As Long
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
szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")
rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1
'***Need Help implementing a way to find exisiting ID numbers, or if Exisiting = 0 then INSERT new row into worksheet***'
Select Case LType '// Choose which columns based on Type
Case "MDIQE"
' If columnvalue = 0 Then
' Update column value
Case "MDIQ"
' If columnvalue = 0 Then
' Update column value
'
'........
'
Case "MDIF"
' If columnvalue = 0 Then
' Update column value
'
End Select
'Error handing & success messagebox
End sub
Thank you for the help,
Wagner
In your SELECT statement, include a WHERE clause to search for the ID in column A, something like this:
SELECT COUNT(*) c
FROM [sourceSheet$sourceRange]
WHERE <ColumnAName> = <ID>
note, this is pseudocode, you'll have to properly assemble the statement just like you did when you assigned a string to szSQL
Then check your result set for the value of c, something like this:
If rsData.Fields("c").value = 0 Then
'ID was NOT found, execute SQL INSERT here
Else
'ID was found, execute SQL UPDATE here
End If
i.e., treat your Excel worksheet like a database.
Of course, it would be better if you could use Access as a database (or SQL Server, or Oracle, or ...) since, well, that's what they're designed to do. But I understand that sometimes you've just got to roll with what you've got.
I currently have a spreadsheet with two work sheets. The first worksheet is a list of names and addresses, the second is a list with names and addresses plus email addresses (sheet is named "EmailList")
I am trying to add a new column to the first worksheet that will show the email address if the email is in the second sheet by matching the firstname, lastname, house number and street address. Even better would be to show the list on a new sheet with just whole rows that match.
I got the email showing using:
=INDEX(EmailList!P:P, MATCH(A9&B9&C9&E9, EmailList!A:A&EmailList!B:B&EmailList!C:C&EmailList!E:E, 0))
However it is soooooo slow. The first sheet has a 1000 rows, the second sheet 1500.
How can I easily select the rows from the EmailList sheet where the Firstname, Lastname, Number, Street name columns in both sheets match?
The comments by pnuts and Parfait are both excellent suggestions and worth considering.
I'm just wondering if your structural logic is correct. From what you write in your questions, rather than find email address for Sheet1, aren't you actually removing from Sheet2 any addresses that don't exist on Sheet1? If this is the case, then a VBA solution would be quite short and simple. If you created a string key from your names, house number, address cells, you could populate a Collection and simply look up that key in each Sheet2 entry. Some skeleton code for you to develop would be as follows:
Option Explicit
Sub RunMe()
Dim data As Variant
Dim r As Long, c As Long, i As Long
Dim key As String
Dim addrs As Collection
Dim emails As Collection
Dim hit As Boolean
Dim vRow As Variant
Dim output As Variant
'Read addresses from Sheet1 into collection
data = Sheet1.UsedRange.Value2
Set addrs = New Collection
For r = 1 To UBound(data, 1)
key = BuildKey(data, r)
addrs.Add True, key
Next
'Interrogate email list
data = Sheet2.UsedRange.Value2
Set emails = New Collection
On Error Resume Next
For r = 1 To UBound(data, 1)
key = BuildKey(data, r)
hit = False
hit = addrs(key)
If hit Then emails.Add r
Next
On Error GoTo 0
'Write your results to the new sheet
ReDim output(1 To emails.Count, 1 To 5)
i = 1
For Each vRow In emails
For c = 1 To 5
output(i, c) = data(vRow, c)
Next
i = i + 1
Next
Sheet3.Range("A1").Resize(UBound(output, 1), UBound(output, 2)).Value = output
End Sub
Private Function BuildKey(data As Variant, r As Long) As String
Dim c As Long
For c = 1 To 4
BuildKey = BuildKey & CStr(data(r, c)) & "|"
Next
End Function
As mentioned, consider SQL if using Excel for PC. Excel can connect to the Jet/ACE SQL Engine (Window .dll files) to run queries on worksheets as if they were database tables. And yes, you can query the very workbook you run the macro as you will use a read-only instance of last saved file.
Specifically, the query below runs an INNER JOIN between two sheets, MainList and EmailList on the very columns you specified with output to existing worksheet, Results:
Sub RunSQL()
Dim conn As Object, rst As Object
Dim strConnection As String, strSQL As String
Dim i As Integer
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' CONNECTION STRINGS (DRIVER VERSION COMMENTED OUT)
' strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
' & "DBQ=C:\Path\To\Workbook.xlsm;"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='C:\Path\To\Workbook.xlsm';" _
& "Extended Properties=""Excel 12.0;HDR=YES;"";"
strSQL = " SELECT t1.*, t2.[EmailAddress]" _
& " FROM [MainList$] t1" _
& " INNER JOIN [EmailList$] t2" _
& " ON t1.FirstName = t2.FirstName" _
& " AND t1.LastName = t2.LastName" _
& " AND t1.HouseNumber = t2.HouseNumber" _
& " AND t1.StreeAddress = t2.StreetAddress;"
' OPEN CONNECTION
conn.Open strConnection
rst.Open strSQL, conn
' COLUMN HEADERS
For i = 1 To rst.Fields.Count - 1
Worksheets("Results").Cells(1, i) = rst.Fields(i).Name
Next i
' DATA ROWS
Worksheets("Results").Range("A2").CopyFromRecordset rst
rst.Close: conn.Close
End Sub
I know this is a dev site, but if you want a super-easy to do this with no code whatsoever, you can use PowerPivot, which is a free AddIn.
You can get the AddIn from here.
https://support.office.com/en-us/article/Power-Pivot-Add-in-a9c2c6e2-cc49-4976-a7d7-40896795d045
Again, it's just another option for you. I like Parfait's suggestion! Very elegant, sir!!
I have a csv file that has approx 600 fields and approx 100k of rows, i would like to import only select fields and only certian rows where a select set of fields match a certain set of criteria into an existing excel worksheet tab
I attempted to use ms query within excel but it stops at 255 columns, i can import the whole file in excel 2010 (250m) but it is a memory hog and by the time i remove the unneeded fields and rows it locks up my computer.
I would like to kick the import process off with an excel vba macro. I have all the front end code of file selection, etc.... But need some assistance in the text read query convert to excel area of vba
Any assitance would be greatly appreciated
Thanks
Tom
For that many records you would be better off importing the .csv into Microsoft Access, indexing some fields, writing a query that contains only what you want, and then exporting to Excel from the query.
If you really need an Excel-only solution, do the following:
Open up the VBA editor. Navigate to Tools -> References. Select the most recent ActiveX Data Objects Library. (ADO for short). On my XP machine running Excel 2003, it's version 2.8.
Create a module if you don't have one already. Or create one anyway to contain the code at the bottom of this post.
In any blank worksheet paste the following values starting at cell A1:
SELECT Field1, Field2
FROM C:\Path\To\file.csv
WHERE Field1 = 'foo'
ORDER BY Field2
(Formatting issues here. select from, etc should each be in their own row in col A for reference. The other stuff are the important bits and should go in column B.)
Amend the input fields as appropriate for your filename and query requirements, then run thegetCsv() subroutine. It will put the results in a QueryTable object starting at cell C6.
I personally hate QueryTables but the .CopyFromRecordset method I prefer to use with ADO doesn't give you field names. I left the code for that method in, commented out, so you can investigate that way. If you use it, you can get rid of the call to deleteQueryTables() because it's a really ugly hack, it deletes whole columns which you may not like, etc.
Happy coding.
Option Explicit
Function ExtractFileName(filespec) As String
' Returns a filename from a filespec
Dim x As Variant
x = Split(filespec, Application.PathSeparator)
ExtractFileName = x(UBound(x))
End Function
Function ExtractPathName(filespec) As String
' Returns the path from a filespec
Dim x As Variant
x = Split(filespec, Application.PathSeparator)
ReDim Preserve x(0 To UBound(x) - 1)
ExtractPathName = Join(x, Application.PathSeparator) & Application.PathSeparator
End Function
Sub getCsv()
Dim cnCsv As New ADODB.Connection
Dim rsCsv As New ADODB.Recordset
Dim strFileName As String
Dim strSelect As String
Dim strWhere As String
Dim strOrderBy As String
Dim strSql As String
Dim qtData As QueryTable
strSelect = ActiveSheet.Range("B1").Value
strFileName = ActiveSheet.Range("B2").Value
strWhere = ActiveSheet.Range("B3").Value
strOrderBy = ActiveSheet.Range("B4").Value
strSql = "SELECT " & strSelect
strSql = strSql & vbCrLf & "FROM " & ExtractFileName(strFileName)
If strWhere <> "" Then strSql = strSql & vbCrLf & "WHERE " & strWhere
If strOrderBy <> "" Then strSql = strSql & vbCrLf & "ORDER BY " & strOrderBy
With cnCsv
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & ExtractPathName(strFileName) & ";" & _
"Extended Properties=""text;HDR=yes;FMT=Delimited(,)"";Persist Security Info=False"
.Open
End With
rsCsv.Open strSql, cnCsv, adOpenForwardOnly, adLockReadOnly, adCmdText
'ActiveSheet.Range("C6").CopyFromRecordset rsCsv
Call deleteQueryTables
Set qtData = ActiveSheet.QueryTables.Add(rsCsv, ActiveSheet.Range("C6"))
qtData.Refresh
rsCsv.Close
Set rsCsv = Nothing
cnCsv.Close
Set cnCsv = Nothing
End Sub
Sub deleteQueryTables()
On Error Resume Next
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim qt As QueryTable
Dim qtName As String
Dim nName As Name
For Each qt In ActiveSheet.QueryTables
qtName = qt.Name
qt.Delete
For Each nName In Names
If InStr(1, nName.Name, qtName) > 0 Then
Range(nName.Name).EntireColumn.Delete
nName.Delete
End If
Next nName
Next qt
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
You can parse your input file extracting the lines that conform to your criteria. The following code uses the split function on each line of the CSV file to separate the fields and then checks to see if it matches the required criteria. If all the criteria match then selected fields are saved in a new CSV file then you can just open the smaller file. You will need to set the microsoft scripting runtime reference in the VBA editor for this to work.
This method should use little memory as it processes 1 line at a time, I tested it on data of 600 fields and 100000 lines and it took about 45 seconds to process the file with no noticable increase in RAM usage in windows task manager. It is CPU intensive and the time taken would increase as the complexity data, conditions and the number of fields copied increases.
If you prefer to write directly to an existing sheet this can be easily acheived, but you would have to rememove any old data there first.
Sub Extract()
Dim fileHandleInput As Scripting.TextStream
Dim fileHandleExtract As Scripting.TextStream
Dim fsoObject As Scripting.FileSystemObject
Dim sPath As String
Dim sFilenameExtract As String
Dim sFilenameInput As String
Dim myVariant As Variant
Dim bParse As Boolean 'To check if the line should be written
sFilenameExtract = "Exctract1.CSV"
sFilenameInput = "Input.CSV"
Set fsoObject = New FileSystemObject
sPath = ThisWorkbook.Path & "\"
'Check if this works ie overwrites existing file
If fsoObject.FileExists(sPath & sFilenameExtract) Then
Set fileHandleExtract = fsoObject.OpenTextFile(sPath & sFilenameExtract, ForWriting)
Else
Set fileHandleExtract = fsoObject.CreateTextFile((sPath & sFilenameExtract), True)
End If
Set fileHandleInput = fsoObject.OpenTextFile(sPath & sFilenameInput, ForReading)
'extracting headers for selected fields in this case the 1st, 2nd and 124th fields
myVariant = Split(fileHandleInput.ReadLine, ",")
fileHandleExtract.WriteLine (myVariant(0) & "," & _
myVariant(1) & "," & _
myVariant(123))
'Parse each line (row) of the inputfile
Do While Not fileHandleInput.AtEndOfStream
myVariant = Split(fileHandleInput.ReadLine, ",")
'Set bParse initially to true
bParse = True
'Check if the first element is greater than 123
If Not myVariant(0) > 123 Then bParse = False
'Check if second element is one of allowed values
'Trim used to remove pesky leading or lagging values when checking
Select Case Trim(myVariant(1))
Case "Red", "Yellow", "Green", "Blue", "Black"
'Do nothing as value found
Case Else
bParse = False 'As wasn't a value in the condition
End Select
'If the conditions were met by the line then write specific fields to extract file
If bParse Then
fileHandleExtract.WriteLine (myVariant(0) & "," & _
myVariant(1) & "," & _
myVariant(123))
End If
Loop
'close files and cleanup
fileHandleExtract.Close
fileHandleInput.Close
Set fileHandleExtract = Nothing
Set fileHandleInput = Nothing
Set fsoObject = Nothing
End Sub
I want to import a CSV file that looks like this (the comma is the seperator):
x,y
Here, x represents a user ID, and y the value I want to extract.
Secondly I have an Excel file that has similar but way fewer user IDs in its first column. I want to import the y-value of only those users that are included in the Excel file.
Does anyone know how to do that?
You can use ADO. Roughly:
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim TextInput As String
''This is not the best way to refer to the workbook
''you want, but it is very convenient for notes
''It is probably best to use the name of the workbook.
strFile = ActiveWorkbook.FullName
''Note that if HDR=No, F1,F2 etc are used for column names,
''if HDR=Yes, the names in the first row of the range
''can be used.
''
''This is the ACE connection string, you can get more
''here : http://www.connectionstrings.com/excel
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
TextInput = "[Text;FMT=Delimited;HDR=Yes;IMEX=2;DATABASE=Z:\docs]"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
strSQL = "SELECT a.ID,a.Data " _
& "FROM " & TextInput & ".[TestIn.csv] a " _
& "INNER JOIN [Sheet1$] b ON a.ID=b.ID" _
rs.Open strSQL, cn, 3, 3
''Pick a suitable empty worksheet for the results
Worksheets("Sheet3").Cells(2, 1).CopyFromRecordset rs
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
Assuming you have unique user IDs in your data (both the Excel file and the CSV), I would simply bring the CSV into Excel on a separate tab, then do a simple VLOOKUP() with the subset of IDs you need (in the Excel file) to get those specific y values.
Note: I know this isn't really filtering anything before bringing in the CSV, but it gets the job done (pulling out y values) fairly easily. If you're looking to automate this task, then hopefully someone has a more programmatic answer :)
I would do something like this where you check yourself for each user ID. Change it to make it work for you. It should go pretty fast.
Note: I have a reference to Microsoft Scripting Runtime which enables the Dictionary, FileSystemObject, File, and TextStream objects.
Sub test()
Dim i As Long
Dim dicItems As Dictionary
Dim fso As FileSystemObject
Dim oFile As File
Dim saItems() As String, saReturn() As String
Dim oStream As TextStream
Dim vUserID As Variant
'Get stream of file
Set fso = New FileSystemObject
Set oFile = fso.OpenTextFile("YourFile.csv")
Set oStream = oFile.OpenAsTextStream(ForReading)
Set dicItems = New Dictionary
'loop through items that you want extracted and put in dictionary
vUserID = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value2
ReDim saReturn(1 To UBound(vUserID))
For i = 1 To UBound(vUserID)
dicItems.Add vUserID(i, 1), i
Next i
'Loop through stream lines
Do While Not oStream.AtEndOfStream
saItems = Split(oStream.ReadLine, ",")
If dicItems.Exists(saItems(0)) Then
saReturn(dicItems(saItems(0))) = saItems(1)
End If
Loop
'Return information to your spreadsheet
Range("B1", Range("B" & UBound(saReturn))) = Application.Transpose(saReturn)
End Sub
I am not very techi-but I have been recording and editing basic Excel Macros for a little while. I have found a few results which almost match my issue, however I am struggling to adapt it so I am hoping someone might be kind enough to help me?!
my issue:
Sheet 1
a/b/c/d
name/black/blue/green
Sam/1//1
Jill//1/
Jill/1//
Sam//1//
Sam/1/1/1
I have a name data base with duplicates in it. I need to de-dupe these, copy just one name (column a) onto a new page, and in the process I don't want to lose some of the data (column b-d) which might be in a duplicate name but not in the one going to be copied over.
Outcome I am hoping for:
Sheet 2
a/b/c/d
name/black/blue/green
Sam/1/1/1
Jill/1/1/
I have quite a few columns to search for data my example is b-d however it is actually AP-EC so it would be helpful if it is obvious which figures I might need to change...?
Thanks in advance.
Kez
You could try ADO, for example:
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim strWhere As String
Dim i As Integer
''http://support.microsoft.com/kb/246335
''This saves the name of the active workbook, as this is an example, it is best
''to save before running the code.
strFile = ActiveWorkbook.FullName
''This is a standard connection string for Excel and ADO, it depends on strFile
''being the name of the current workbook, it should be, because that is
''what the first line does
''Note also HDR=Yes, this means that the code expects the first row to be headers,
''in this case, Name, Black, Blue, Green
''You can get more on connection strings from: http://www.connectionstrings.com/
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";"
''This creates the objects needed in the code
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
''This opens the connection
cn.Open strCon
''This is fairly ordinary SQL, if you are having problems, try a simpler statement
''such as
''SELECT * FROM [Sheet3$]
''It is important that you choose a sheet that exists in the activeworkbook
''and that the sheet has data.
strSQL = "SELECT a.[Name], " _
& "(SELECT Max([Black]) FROM [Sheet3$] b WHERE b.[Name]=a.Name ) As Black, " _
& "(SELECT Max([Blue]) FROM [Sheet3$] b WHERE b.[Name]=a.Name ) As Blue, " _
& "(SELECT Max([Green]) FROM [Sheet3$] b WHERE b.[Name]=a.Name ) As Green " _
& "FROM [Sheet3$] a " _
& "GROUP BY a.[Name]"
''This uses the connection (cn) to open a recordset with the SQL (strSQL)
''3, 3 refers to the cursor and lock type.
''More here: http://www.w3schools.com/ADO/met_rs_open.asp
rs.Open strSQL, cn, 3, 3
''All this does is put headers in sheet of your choice, I chose sheet5.
For i = 0 To rs.fields.Count - 1
Sheets("Sheet5").Cells(1, i + 1) = rs.fields(i).Name
Next
''This copies the recordset into the sheet of your choice,
''Sheet5 again, in this case
Worksheets("Sheet5").Cells(2, 1).CopyFromRecordset rs