Question

我正在创建与Sybase数据库的ADODB连接，在记录集中执行SQL语句，然后使用CopyFromRecordset方法将记录集的内容粘贴到某个范围。这一直很好，但我最近在工作中移动了PC，现在其中一个列没有返回任何内容。

当我在SQuirreL中运行相同的SQL时，该列不是空白的。

如果我暂停VBA并尝试查看有问题的列/字段中的一个值（即在即时窗口中的rst.fields（1）.value），我会收到以下错误消息：

运行时错误'-2147467259（80004005）'：未指定错误。

在Squirrel结果元数据选项卡中，相关列描述为：

ColumnIndex 2
 getColumnName CommentText
 getColumnTypeName text
 getPrecision 2147483647
 getScale 0
 isNullable 0
 getTableName xxxxxxx
 getSchemaName 
 getCatalogName 
 getColumnClassName java.sql.Clob
 getColumnDisplaySize 2147483647
 getColumnLabel CommentText
 getColumnType 2005
 isAutoIncrement FALSE
 isCaseSensitive FALSE
 isCurrency FALSE
 isDefinitelyWritable FALSE
 isReadOnly FALSE
 isSearchable FALSE
 isSigned FALSE
 isWritable TRUE

有问题的代码如下所示，但是，如上所述，代码似乎不是问题，因为它之前有效 - 任何想法？

Sub ImportComments()

Dim wsData As Worksheet
Dim rng As Range
Dim cn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim x As Long
Dim rngSQL  As Range
Dim cell As Range
Dim sSQL As String
Dim sProvider As String
Dim sDS As String
Dim sDataSource As String
Dim sUser As String
Dim sCatalog As String
Dim sPassword As String
Dim rngDS As Range
Dim rngThisDS As Range
Dim sConnect As String
Dim sInstance As String
Dim fSuccess As Boolean
Dim sError As String

On Error GoTo ProcExit

'delete previous comments if they exist
If SheetExists("Comments_Data_Import", ThisWorkbook) = True Then
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("Comments_Data_Import").Delete
    Application.DisplayAlerts = True
End If

'create comments sheet
Set wsData = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets("EWI_Data_Import"))
wsData.Name = "Comments_Data_Import"

'build sql string
Set rngSQL = Range(ThisWorkbook.Sheets("SQL").Range("A2"), _
                ThisWorkbook.Sheets("SQL").Range("A2").End(xlDown))
For Each cell In rngSQL
    sSQL = sSQL & cell.Value & " "
Next cell

'define login components
Set rngDS = ThisWorkbook.Worksheets("Login").Range("rngInstance").CurrentRegion
Set rngDS = rngDS.Offset(1, 0).Resize(rngDS.Rows.Count - 1)
sProvider = "Provider=ASEOLEDB.1;"
sUser = "User ID=" & ThisWorkbook.Worksheets("Login").Range("rngUsername").Value & ";"
sPassword = "Password=" & ThisWorkbook.Worksheets("Login").Range("rngPassword").Value

'try to log in to each instance exiting when succesful
Set cn = New ADODB.Connection
cn.CommandTimeout = 600

'turn off error hadling to allow for connection errors    On Error Resume Next

For Each rngThisDS In rngDS.Rows

    'complete connect string
    Err = 0
    sInstance = rngThisDS.Cells(1, 1)
    sDS = "Data Source=" & rngThisDS.Cells(1, 2) & ";"
    sCatalog = "Initial Catalog=" & rngThisDS.Cells(1, 3) & ";"
    sConnect = sProvider & sDS & sUser & sCatalog & sPassword


    'attempt to open
    cn.Open sConnect

    'If successful Then
    If Err = 0 Then

        'flag success
        fSuccess = True

        'execute SQL
        On Error GoTo ProcError
        Set rst = cn.Execute(sSQL)

        'copy data into comments sheet
        wsData.Range("A2").CopyFromRecordset rst


        'Put in the headers
        Set rng = wsData.Range("A1")
        For x = 1 To rst.Fields.Count
            rng.Offset(0, x - 1).Value = rst.Fields(x - 1).Name
        Next x
        FormatComments
        Exit For
    End If

Next rngThisDS

If fSuccess = False Then
    MsgBox ("Unable to connect to Insight")
Else
       MsgBox "Connected to and exported data from " & sInstance
End If

ProcExit:
Set wsData = Nothing
Set rng = Nothing
Set cn = Nothing
Set rst = Nothing
Set rngSQL = Nothing
Set cell = Nothing
Set rngDS = Nothing
Set rngThisDS = Nothing

Exit Sub

ProcError:

    MsgBox "Error: " & Err.Description
    Resume ProcExit

End Sub

Answer 1

根据CopyFromRecordset() MSDN：

当此方法将记录集复制到工作表时，结果如果您未指定足够大的范围，则会被截断保存记录集的内容。

考虑使用MoveFirst命令重置指定范围：

' Copy data into comments sheet
rst.MoveLast
rst.MoveFirst
wsData.Range("A2:Z500").CopyFromRecordset rst

或整个工作表（从A1开始，当然是为列标题插入行）

wsData.Cells.CopyFromRecordset rst

但即便如此，CopyFromRecordset()对数据和粗略类型甚至内存都很敏感（因为你拉动所有数据并立即转储），所以考虑完全替换方法并迭代行的记录。甚至其他语言（PHP，Python，Java等）也以这种方式运行查询，打开游标并迭代结果集。

' Put in the headers
Set rng = wsData.Range("A1")
For x = 1 To rst.Fields.Count
      rng.Offset(0, x - 1).Value = rst.Fields(x - 1).Name
Next x

' Put in rows
Dim col As Integer, row As Integer
rst.MoveLast
rst.MoveFirst

Set rng = wsData.Range("A2")
row = 0
Do While Not rst.EOF
    For col = 0 To rst.Fields.Count - 1
            rng.Offset(row, col).Value = rst(col)
    Next col
    row = row + 1
    rst.MoveNext
Loop

copyfromrecordset返回空白列

1 个答案: