在现有的ADO记录集中追加字段

Question

我在Excel中使用ADO记录集以获取巨大的CSV（约1百万行）并将其用作外部数据以创建PivotCache & Pivottable。

我想编辑的记录追加附加字段（列），并添加从即具有这样字符串数据一周字段中的一个字段计算数据：

例如如果A，B，C是记录字段，

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 

然后我想附加字段d，E和如上所示，从塔A剥离等我将在Excel中做数据添加到它们，

D = VALUE（RIGHT（A2,2）） E = VALUE（MID（A2,3,4））

但我想使用SQL函数。

然后我使用这个附加记录集来创建一个pivotcache和一个使用它作为外部数据源的透视表。我的CODE.i中的注释无法将记录集克隆到一个新的记录集中，也因为它给了我一些不可用的书签错误。

下面给我的错误：

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 

Answer 1

您可以创建你的原始SQL查询这些新的领域。

这是一个简化的例子：我查询一个txt文件“week.txt”（它只有一个带有“week”和几行测试数据的列）并将记录集放到工作表上。

Sub GetCSV() 

    Dim SQL As String 
    Dim sConnStrP1 As String 
    Dim cConnection As Object 
    Dim rsRecordset As Object, RS As Object 
    Dim Conn As Object, i As Integer 

    Set rsRecordset = CreateObject("ADODB.Recordset") 
    Set RS = CreateObject("ADODB.Recordset") 
    Set cConnection = CreateObject("ADODB.Connection") 

    sConnStrP1 = "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _ 
       "Dbq=C:\_Stuff\test\" & _ 
       ";Extensions=asc,csv,tab,txt;FIL=text;Persist Security Info=False" 

    cConnection.Open sConnStrP1 

    'create new columns based on "week" column 
    ' 1*(....) coerces to number 
    SQL = "SELECT [week], 1*(right(week,2)) as wk_num, 1*(mid(week,3,4)) as year FROM [week.txt]" 

    Set rsRecordset = cConnection.Execute(SQL) 

    'drop to sheet... 
    With ActiveSheet.Range("D5") 
     For i = 0 To rsRecordset.Fields.Count - 1 
      .Offset(0, i).Value = rsRecordset.Fields(i).Name 
     Next i 
     .Offset(1, 0).CopyFromRecordset rsRecordset 
    End With 


End Sub