Append Fields in an Existing ADO Recordset
hi,
I am using an ADO recordset in Excel to grab a huge CSV (~1 million rows) and use it as External data to create a PivotCache & Pivottable.
I want to edit the recordset to append additional fields (columns) and add data that is calculated from one of the fields viz a week field which has string data like this:
e.g. if A, B, C are the recordset fields,
A B C D E
w 2011 01 01 2011
w 2011 02 02 2011
w 2011 03 03 2011
w 2011 04 04 2011
w 2012 05 05 2012
then I want to append fields D, E and add data to them as shown above, stripped from column A like I would do in excel,
D = VALUE(RIGHT(A2,2))
E = VALUE(MID(A2,3,4))
but I want to do using SQL functions.
then I use this appended recordset to create a pivotcache and a pivottable using it as an external datasource.
SEE MY COMMENTS IN THE CODE.
PHP Code:
Option Explicit
Sub GetCSV()
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim sFileName As String
Dim sFilePath As String
Dim rngPivotDest As Range
Dim pcPivotCache As PivotCache
Dim ptPivotTable As PivotTable
Dim SQL As String
Dim sConnStrP1 As String
Dim sConnStrP2 As String
Dim cConnection As Object
Dim rsRecordset As Object, RS As Object, Fld As Object
Dim Sht As Worksheet
Dim Conn As Object
With ThisWorkbook
Set rsRecordset = CreateObject("ADODB.Recordset")
Set RS = CreateObject("ADODB.Recordset")
Set cConnection = CreateObject("ADODB.Connection")
sFileName = Application.GetOpenFilename("Text Files, *.asc; *.txt; *.csv", 1, "Select a Text File", , False)
sFilePath = Left(sFileName, InStrRev(sFileName, "\"))
sFileName = Replace(sFileName, sFilePath, "")
sConnStrP1 = "Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq="
sConnStrP2 = ";Extensions=asc,csv,tab,txt;FIL=text;Persist Security Info=False"
cConnection.Open sConnStrP1 & sFilePath & sConnStrP2
SQL = "SELECT * FROM [" & sFileName & "]"
Set rsRecordset = cConnection.Execute(SQL)
'****** THIS ENTIRE PART IS NOT WORKING******
With RS
.cursorlocation = 3 'aduseclient
.cursortype = 2 'adOpenDynamic 3 'adopenstatic
' For Each Fld In rsRecordset.Fields
' .Fields.append Fld.Name, Fld.Type, Fld.definedsize, Fld.Attributes, Fld.adFldIsNullable
' Next Fld
.locktype = 4 'adLockBatchOptimistic'3 'adlockoptimistic
.Fields.append "WeekNumber", 3 'adinteger
.Fields.append "Year", 7 'addate
.Open
.Update
'do something to grab the entire data into RS
Set RS = rsRecordset.Clone
'or something like
Set RS = rsRecordset.getrows
'append some function code to the last 2 fields to strip YEAR & WEEK from 1st field.
......
......
End With
*********************************
'Delete any connections in workbook
On Error Resume Next
For Each Conn In .Connections
Conn.Delete
Next Conn
On Error GoTo 0
'Delete the Pivot Sheet
On Error Resume Next
For Each Sht In .Sheets
If LCase(Trim(Sht.Name)) = LCase("Pivot") Then Sht.Delete
Next Sht
On Error GoTo 0
'Create a PivotCache
Set pcPivotCache = .PivotCaches.Create(SourceType:=xlExternal)
Set pcPivotCache.Recordset = rsRecordset
'Create a Pivot Sheet
.Sheets.Add after:=.Sheets("Main")
ActiveSheet.Name = "Pivot"
'Create a PivotTable
Set ptPivotTable = pcPivotCache.CreatePivotTable(TableDestination:=.Sheets("Pivot").Range("A3"))
With ptPivotTable
.Name = "PivotTable"
.SaveData = False
End With
With ptPivotTable
With .PivotFields("Level")
.Orientation = xlPageField
.Position = 1
End With
With .PivotFields("Cat")
.Orientation = xlPageField
.Position = 1
End With
With .PivotFields("Mfgr")
.Orientation = xlPageField
.Position = 1
End With
With .PivotFields("Brand")
.Orientation = xlPageField
.Position = 1
End With
With .PivotFields("Descr")
.Orientation = xlRowField
.Position = 1
End With
End With
ptPivotTable.AddDataField ptPivotTable.PivotFields("Sales Value from CrossCountrySales"), "Sum of Sales Value from CrossCountrySales", xlSum
With ptPivotTable.PivotFields("Week")
.Orientation = xlColumnField
.Position = 1
End With
With ptPivotTable.PivotFields("Sum of Sales Value from CrossCountrySales")
.Calculation = xlNoAdditionalCalculation
End With
cConnection.Close
Set rsRecordset = Nothing
Set cConnection = Nothing
Set Conn = Nothing
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
