Question

我在Excel中使用ADO记录集来获取巨大的CSV（约100万行）并将其用作外部数据来创建数据透视表和数据库。数据透视表。

我想编辑记录集以附加其他字段（列）并添加从其中一个字段计算的数据，该字段具有字符串数据，如下所示：

e.g。如果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（右（A2,2）） E = VALUE（MID（A2,3,4））

但我想使用SQL函数。

然后我使用这个附加的记录集来创建一个pivotcache和一个pivottable，使用它作为外部数据源。在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文件＆＃34; week.txt＆＃34; （只有一列带有标题＆＃34;周＆＃34;以及几行测试数据）并将记录集放到工作表上。

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

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

1 个答案: