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

Question

我在 Excel 中使用 ADO 记录集来获取一个巨大的 CSV（约 100 万行）并将其用作外部数据来创建 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 = 值（右（A2,2）） E = 值（中（A2,3,4））

但我想使用 SQL 函数。

然后我使用这个附加的记录集来创建一个数据透视缓存和一个将它用作外部数据源的数据透视表。在代码中查看我的评论。我无法将记录集克隆到新的记录集中，因为它给了我一些书签不可用的错误。

以下给了我错误：

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