Using ADODB to write to Excel file - excel

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.

Related

Pivot full text instead of counts - Excel

I'm trying to determine the most efficient/effective way to display specific rows from a central table on sheet1 as text on sheet2.
I have setup a table that contains numerous events that is continually being used by multiple people. This sheet acts as a central database and is shared with multiple people who are all using it in real time.
I want to provide a table on sheet2 that allows other users to view specific events from the central database. So I need to export specific values from sheet1 to sheet2. I understand this can easily be done using a filter but the table on sheet1 is constantly being used and it can't be disrupted.
I can't just do a sort or filter on the sheet1 table because it needs to be used by other parties at all times
I really only need to view specific values from sheet1 for the last month. I've got code the exports all rows based off a specific value entered into a designated column on Sheet1. But due to the size of the file Excel constantly crashes.
I then thought a pivot table may be easier and I wouldn't have to use VBA. Is it possible to pivot out specific rows as text, which can be grouped by date, e.g. month?
For instance, if I want to view all ['A's'] and ['X's'] from Column B from the last month as full text it would look like the following:
Central Database table Sheet1
A B C D
0 11/1 A Big Dog
1 10/1 X 1 2
2 11/1 Y Y Y
3 1/2 A Big Cat
4 1/2 X 3 4
5 1/2 Y Y Y
Output table Sheet2
A B C D
1 1/2 A Big Cat
2 1/2 X 3 4
As others have mentioned in the comments, using SQL with ADODB is likely a better approach than using PivotTables. I'd also recommend separating your data (Sheet1) from your presentation layer (Excel). E.g. store your data in an actual database like Access, SQL Server etc.
However, as you are looking for a stop gap, I figured I could give you an approach that might fill the need temporarily. The code is commented, but feel free to ask questions. You will need to add a reference to Microsoft Active X Data Object 2.8 or greater to get this working. How to add a reference?
Early Binding Approach
Option Explicit
Public Sub DisplayView(StartDate As Date, EndDate As Date)
'Add a reference to Microsoft Active X Data Object 2.8 or greater
Dim dbConnection As ADODB.Connection
Dim dbRecordset As ADODB.Recordset
Dim dbCommand As ADODB.Command
Dim OutputSheet As Excel.Worksheet
Dim dbField As Variant
Dim fieldCounter As Long
Set dbConnection = New ADODB.Connection
Set dbRecordset = New ADODB.Recordset
Set dbCommand = New ADODB.Command
Set OutputSheet = ThisWorkbook.Worksheets("Sheet2")
'Do a quick check to determine the correct connection string
'if one of these don't work, have a look here --> https://www.connectionstrings.com/excel/
If Left$(ThisWorkbook.FullName, 4) = "xlsm" Then
dbConnection.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
ThisWorkbook.FullName & ";Extended Properties='Excel 12.0 Macro;HDR=YES';"
Else
dbConnection.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES';"
End If
'Open the connection and parameterize the query
dbConnection.Open
With dbCommand
.ActiveConnection = dbConnection
.CommandType = adCmdText
'A in B in the text below are the field names in your Sheet 1
'I wasn't sure what the names of the fields are so I named them as they appeared
'That being Column A is called A, Column B is called B etc
.CommandText = "Select * from [Sheet1$] where B in ('A','X') and A >= #StartDate and A < #EndDate"
.Parameters.Append .CreateParameter("#StartDate", adDate, adParamInput, , StartDate)
.Parameters.Append .CreateParameter("#EndDate", adDate, adParamInput, , EndDate)
Set dbRecordset = .Execute
End With
'Clear the Output Sheet
OutputSheet.Cells.Clear
'Add Headers to output
For Each dbField In dbRecordset.Fields
fieldCounter = fieldCounter + 1
OutputSheet.Cells(1, fieldCounter).Value2 = dbField.Name
Next
'Dump the found records
OutputSheet.Range("A2").CopyFromRecordset dbRecordset
If dbConnection.State = adStateOpen Then dbConnection.Close
End Sub
'Run from here
Public Sub ExampleRunner()
'Supply the dates you want to filter for
DisplayView #1/1/2019#, #1/20/2019#
End Sub
As requested, here is the Late Binding Approach that doesn't require an explicit reference to Microsoft Active X Data Object.
Option Explicit
Private Const adCmdText As Long = 1
Private Const adDate As Long = 7
Private Const adParamInput As Long = 1
private const adStateOpen as long = 1
Public Sub DisplayView(StartDate As Date, EndDate As Date)
'Add a reference to Microsoft Active X Data Object 2.8 or greater
Dim dbField As Variant
Dim fieldCounter As Long
Dim dbConnection As Object
Dim dbRecordset As Object
Dim dbCommand As Object
Dim OutputSheet As Excel.Worksheet
Set dbConnection = CreateObject("ADODB.Connection")
Set dbRecordset = CreateObject("ADODB.Recordset")
Set dbCommand = CreateObject("ADODB.Command")
Set OutputSheet = ThisWorkbook.Worksheets("Sheet2")
'Do a quick check to determine the correct connection string
'if one of these don't work, have a look here --> https://www.connectionstrings.com/excel/
If Left$(ThisWorkbook.FullName, 4) = "xlsm" Then
dbConnection.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
ThisWorkbook.FullName & ";Extended Properties='Excel 12.0 Macro;HDR=YES';"
Else
dbConnection.connectionstring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES';"
End If
'Open the connection and parameterize the query
dbConnection.Open
With dbCommand
.ActiveConnection = dbConnection
.CommandType = adCmdText
'A in B in the text below are the field names in your Sheet 1
'I wasn't sure what the names of the fields are so I named them as they appeared
'That being Column A is called A, Column B is called B etc
.CommandText = "Select * from [Sheet1$] where B in ('A','X') and A >= #StartDate and A < #EndDate"
.Parameters.Append .CreateParameter("#StartDate", adDate, adParamInput, , StartDate)
.Parameters.Append .CreateParameter("#EndDate", adDate, adParamInput, , EndDate)
Set dbRecordset = .Execute
End With
'Clear the Output Sheet
OutputSheet.Cells.Clear
'Add Headers to output
For Each dbField In dbRecordset.Fields
fieldCounter = fieldCounter + 1
OutputSheet.Cells(1, fieldCounter).Value2 = dbField.Name
Next
'Dump the found records
OutputSheet.Range("A2").CopyFromRecordset dbRecordset
If dbConnection.State = adStateOpen Then dbConnection.Close
End Sub
'Run from here
Public Sub ExampleRunner()
'Supply the dates you want to filter for
DisplayView #1/1/2019#, #1/20/2019#
End Sub
Here are some screenshots of the Results of the below mentioned Power Query. I selected (In Excel 2003) Data->Import External Data->New Database Query
Then, I chose "Excel Files" and added the data I wanted. Make sure to select "is not null" in the query options. I then added the auto sort feature.
You could use a Power Query in the Sheet2 Excel Workbook. Another link here. This way you could update the data whenever you need to. Then, use SQL to query what you need.
It is pretty simple to use and doesn't take any coding (unless you want to use SQL).
This can be done and then in your other workbook you can do the filtering and sorting.
#ryan-wildry 's post is pretty great (and so is his command text for SQL), but if you do not want to use vba or a database then, you can use this (as well as his SQL text).
An example would be:
SELECT * FROM [Sheet1$] WHERE Column2='X';
The only problem would be if you have mixed datatypes in the same column. As can be seen with rows 1 & 4 (they were not able to come across with the query because the values are not the same type. (This is using Excel 2003 so if you have a newer version then, you may be able to check it with that).
I've been doing some research and found that Excel's Power Query will handle mixed data types so, you should be set if you are using Power Query.

How to transfer an excel spreadsheet to an access database

I'm making a program to track my weight, calories I eat in a day, and the date, to help me lose weight. I'm manually putting in these values into a spreadsheet with those three columns (date, calories, weight). I want to transfer the information in these three columns into an access database.
Code so far:
Sub transferdata()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
connStr = "C:\Users\sachu\Desktop\Assignment 5\CalorieDatabase.mdb"
providerStr = "Microsoft.ACE.OLEDB.12.0"
With cn
.ConnectionString = connStr
.Provider = providerStr
.Open
End With
rs.Open sqlStr, cn
rs.Close
cn.Close
End Sub
So far my code is only starting the connection between access and excel
There are many ways to do this. Let's look at a couple of case studies.
Export data from Excel to Access (ADO)
If you want to export data to an Access table from an Excel worksheet, the macro example below shows how this can be done.
Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=C:\FolderName\DataBaseName.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 3 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("FieldName1") = Range("A" & r).Value
.Fields("FieldName2") = Range("B" & r).Value
.Fields("FieldNameN") = Range("C" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
Also . . .
Export data from Excel to Access (DAO)
If you want to export data to an Access table from an Excel worksheet, the macro example below illustrates another way to do this.
Sub DAOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim db As Database, rs As Recordset, r As Long
Set db = OpenDatabase("C:\FolderName\DataBaseName.mdb")
' open the database
Set rs = db.OpenRecordset("TableName", dbOpenTable)
' get all records in a table
r = 3 ' the start row in the worksheet
Do While Len(Range("A" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("FieldName1") = Range("A" & r).Value
.Fields("FieldName2") = Range("B" & r).Value
.Fields("FieldNameN") = Range("C" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
Also . . .
Browse to a single EXCEL File and Import Data from that EXCEL File via TransferSpreadsheet (VBA)
Here's yet another way . . .
Sub TryThis()
Dim strPathFile As String
Dim strTable As String, strBrowseMsg As String
Dim strFilter As String, strInitialDirectory As String
Dim blnHasFieldNames As Boolean
' Change this next line to True if the first row in EXCEL worksheet
' has field names
blnHasFieldNames = False
strBrowseMsg = "Select the EXCEL file:"
' Change C:\MyFolder\ to the path for the folder where the Browse
' window is to start (the initial directory). If you want to start in
' ACCESS' default folder, delete C:\MyFolder\ from the code line,
' leaving an empty string as the value being set as the initial
' directory
strInitialDirectory = "C:\MyFolder\"
strFilter = ahtAddFilterItem(strFilter, "Excel Files (*.xls)", "*.xls")
strPathFile = ahtCommonFileOpenSave(InitialDir:=strInitialDirectory, _
Filter:=strFilter, OpenFile:=False, _
DialogTitle:=strBrowseMsg, _
Flags:=ahtOFN_HIDEREADONLY)
If strPathFile = "" Then
MsgBox "No file was selected.", vbOK, "No Selection"
Exit Sub
End If
' Replace tablename with the real name of the table into which
' the data are to be imported
strTable = "tablename"
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
strTable, strPathFile, blnHasFieldNames
' Uncomment out the next code step if you want to delete the
' EXCEL file after it's been imported
' Kill strPathFile
End Sub
I know this looks like a dead thread but I wanted to revive for Office 360 users. I had to compile an answer from several sources to make something workable. See below.
First- note that you need at least the 2 following references active in your Tools>References Menu.
Microsoft Access 16.0 Object Library &
Microsoft Office 16.0 Access Database Engine Object
You may also need to have:
Visual Basic for Applications//
Microsoft Excel 16.0 Object Library//
OLE Automation//
Microsoft Forms 2.0 Object Library//
Microsoft Outlook 16.0 Object Library//
Microsoft Office 16.0 Object Library
Sub rtnExporttoAccess()
Dim oDAO As DAO.DBEngine, oDB As DAO.Database, oRS As DAO.Recordset
Dim oSelect As Range, sPath As String, sRecordSet As String
Set sheet = ActiveWorkbook.Worksheets("YourSheet") 'excel sheet
Set table = sheet.ListObjects.Item("YourTable") 'excel table
Set oSelect = table.ListRows(table.ListRows.Count).Range 'set your sheet and range however you want
sPath = "your database file path"
sRecordSet = "the title of the table in that database" 'access table
Set oDAO = New DAO.DBEngine
Set oDB = oDAO.OpenDatabase(sPath)
Set oRS = oDB.OpenRecordset(sRecordSet)
oRSct = oRS.Fields.Count
xclFieldCt = table.ListColumns.Count
If oRSct > xclFieldCt Then
intTargetCt = oRSct
Else
intTargetCt = xclFieldCt
End If
For i = 2 To oSelect.Rows.Count
oRS.AddNew
'finds the correct fields to add data to
For j = 0 To intTargetCt - 1 'access is base 0 so the end is always -1
oRSHeaderName = oRS.Fields(j).Name 'gets database table variable header name
For col = 1 To intTargetCt 'excel is base 1
lastRowHeaderName = table.HeaderRowRange(1, col) ' gets excel table variable header name
If oRSHeaderName = lastRowHeaderName Then 'this verifies both headers are the same
oRS.Fields(j) = Now
Exit For
End If
If oRSHeaderName = "Pass/Failed" And lastRowHeaderName = "Pass/Failed" Then 'this verifies the you are putting the data where you want it if headers arent the same.
oRS.Fields(j) = cbxPF
Exit For
End If
Next col
Next j
oRS.Update
Next i
oDB.Close
End Sub
ASH's second DAO option is basically what this code is as well. I included the references and gave some extra options for you to see some more examples.
Creat a stand alone Acces DB then link the Excel in it. The Access has tools to import data from Excel with live communication.
Follow this:
Open MS Access
Creat new blank database (in this step you have to give name to the database, and set the save location)
In the new database on External Data tab choose the correct type to add based on what you want to import (in this case you have to select Excel)
in the earlier MS Access version the popular insertable things were stretched
in the 2016 version, and O365 the options is more compact so there is one option called New Data Source which contain all possibilities
The import progress consits of several steps.
you have to select the source and set how you want to import data. You can import data into a new table in Access as a copy, or you can connect the source of data to the Access database. Select connect source data for live communication.
select inner data source (for example which sheet, or range you want to import)
set if the first row contain headers
give a name to the linked table
Finally data from Excel linked into Access and it will update when you use it.

VB6 To Xls without Excel

I have to transfer data from several Flexgrids in different Forms in a VB6 application to .xls files in computers which do not have excel installed. Openoffice, LibreOffice, etc are installed in these PCs.
I developed a common procedure which takes a FlexGrid as a parameter and transfers its data to xls. This procedure uses DAO. As various columns in various FlexGrids contain various data types, in the procedure I am defining the fields as type "dbText".
t.Fields.Append t.CreateField(pFlxGrd.TextMatrix(0, j), dbText)
Transfer from any grid to xls is working fine. But, a problem is, for every cell that contains data, single quotes are inserted to indicate its data of Text type.
Is there any way to remove or avoid these quotes? As numeric data are to be used for summations, etc, these quotes have to be gotten rid of.
You can do this with either the Jet engine, ODBC or accdb. If you are on a 64 bit system, make sure you run it from the 32-bit cmd prompt in windows\syswow64\cmd. I don't have VB6 installed so this solution has only been tested in vbscript, which is very similar. You just have to add the types to the dim statement.
dim connExcel, connExcelStr, rsExcel, xlpath
' Get the parameter from the command line
xlpath = WScript.Arguments.Item(0)
' Create the connection
set connExcel = CreateObject("ADODB.Connection")
' Setup the connection string
' xlpath = "U:\JetExcel\data.xls"
connExcelStr = "Driver={Microsoft Excel Driver (*.xls)};"
connExcelStr = connExcelStr & "Dbq=" & xlpath & ";"
connExcelStr = connExcelStr & "FIRSTROWHASNAMES=1;"
connExcelStr = connExcelStr & "READONLY=FALSE;"
connExcelStr = connExcelStr & "CREATE_DB=""" & xlpath & """;"
' Create a workbook
WScript.echo connExcelStr
connExcel.Open connExcelStr
' Create a worksheet
sqlQuery = "create table [Sheet1] (ID Number, FirstName Text, LastName Text)"
WScript.echo sqlQuery
set rsExcel = connExcel.Execute(sqlQuery)
' Put data into the worksheet
sqlQuery = "insert into [Sheet1] (ID, FirstName, LastName) values"
sqlQuery = sqlQuery & "(1, 'Humpty', 'Dumpty')"
WScript.echo sqlQuery
set rsExcel = connExcel.Execute(sqlQuery)
' Close workbook
connExcel.Close
set connExcel = nothing
If the script is named xxx.vbs, to create an excel sheet
cscript xxx.vbs test.xls
There is a much faster solution to copy the data from a flexgrid (without the quotation marks) shown in vbForums from a while back - The advantage of this methods is that they work pretty fast, compared to send/bring data cell by cell
Private Sub FlexToExcel()
Dim xlObject As Excel.Application
Dim xlWB As Excel.Workbook
Set xlObject = New Excel.Application
'This Adds a new woorkbook, you could open the workbook from file also
Set xlWB = xlObject.Workbooks.Add
Clipboard.Clear 'Clear the Clipboard
With MSFlexGrid1
'Select Full Contents (You could also select partial content)
.Col = 0 'From first column
.Row = 0 'From first Row (header)
.ColSel = .Cols - 1 'Select all columns
.RowSel = .Rows - 1 'Select all rows
Clipboard.SetText .Clip 'Send to Clipboard
End With
With xlObject.ActiveWorkbook.ActiveSheet
.Range("A1").Select 'Select Cell A1 (will paste from here, to different cells)
.Paste 'Paste clipboard contents
End With
' This makes Excel visible
xlObject.Visible = True
End Sub
See THIS link for more information.

Vba to import a sub-portion of a hugh csv file into excel 2010

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

Copy and paste cells if Duplicate columns , Excel Macro

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

Resources