vba 在现有 ADO 记录集中追加字段
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/23816140/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Append Fields in an Existing ADO Recordset
提问by sifar
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.
我在 Excel 中使用 ADO 记录集来获取一个巨大的 CSV（约 100 万行）并将其用作外部数据来创建 PivotCache 和数据透视表。
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 是记录集字段，
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、E 并向它们添加数据，如上所示，从 A 列中剥离，就像我在 excel 中所做的那样，
D = VALUE(RIGHT(A2,2)) E = VALUE(MID(A2,3,4))
D = VALUE(RIGHT(A2,2)) E = VALUE(MID(A2,3,4))
but I want to do using SQL functions.
但我想使用 SQL 函数。
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.i cannot clone the recordset into a new recordset also as its giving me some bookmarks not available error.
然后我使用这个附加的记录集来创建一个数据透视缓存和一个数据透视表，使用它作为外部数据源。在代码中查看我的评论。我无法将记录集克隆到新的记录集，因为它给了我一些书签不可用的错误。
the following gives me errors:
以下给了我错误：
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
采纳答案by Tim Williams
You can create those new fields in your original SQL query.
您可以在原始 SQL 查询中创建这些新字段。
Here's a simplified example: I'm querying a txt file "week.txt" (which just has one column with header "week" and a few rows of test data) and dropping the recordset onto a worksheet.
这是一个简化的示例：我正在查询一个 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
