Append Fields in an Existing ADO Recordset

**Junoon** · 05-22-2014, 10:52 PM

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

**LalitPandey87** · 06-26-2014, 12:02 PM

You can not append a new blank field in the same recordset but there is a workaround for this:

First get all data in one recordset which is Recordset1
Then create a new recordset Recordset2 and add all existing field form Recordset1
Add new field in Recordset2
Add data from Recordset1 to Recordset2

Code:

strSql = "Select Column1, Column2 from Table1"
With rs
    .Open strSql, Con, adOpenForwardOnly, adLockBatchOptimistic
End With


rscp.Fields.Append "Column1", adVarChar, 6
rscp.Fields.Append "Column2", adVarChar, 6
rscp.Fields.Append "Column3", adVarChar, 50 'New Column
rscp.Open


For i = 1 To rs.RecordCount
    rscp.AddNew _
    Array("Column1", "Column2", "Column3"), _
    Array(rs.Fields(0).Value, rs.Fields(1).Value, Null)
    rs.MoveNext
Next