Question

在最近的Windows / Office更新之后，当传递xlRangeValueMSPersistXML参数时，Excel的Range.Value属性似乎不起作用，该参数指示范围的Value属性以XML格式返回范围数据。还有其他人遇到这个问题吗？

这是我的代码（贷记https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-the-week-range-to-recordset-without-making-connection/）

    Set adoRecordset = CreateObject("ADODB.Recordset")
    Set xlXML = CreateObject("MSXML2.DOMDocument")
    xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML) <- this fails now
    adoRecordset.Open xlXML

Answer 1

我遇到了同样的问题。我具有相同的代码行，并收到运行时错误：“错误号-2147417848，对象'范围'的方法'值'失败。这是在最新的Excel更新后立即发生的。

我还没有找到代码的解决方法，但是通过回滚到以前的版本设法解决了这个问题。

修复了CNET帖子中的某些拼写错误，并设法回滚了。

打开提升权限的命令窗口，然后转到目录：

cd %programfiles%\Common Files\Microsoft Shared\ClickToRun officec2rclient.exe /update user updatetoversion=16.0.11425.20244

这是Office 365每月发布渠道的最新版本。您可以在这里找到版本：https://docs.microsoft.com/en-us/officeupdates/update-history-office365-proplus-by-date?redirectSourcePath=%252fen-us%252farticle%252fae942449-1fca-4484-898b-a933ea23def7

在Excel中，您需要转到File->Account->Update Options并关闭更新。这不是最佳选择，但是比在修复程序到来之前重写我的代码要好。

Answer 2

对于那些不想回滚办公室或无法回滚办公室的人，我已经开始尝试解决方法。如果可行，它将使用以前的方法，因此它将仅在存在问题的那些计算机上实际运行解决方法。

如果不需要过滤，则可以创建自己的记录集，并从ADODB DataTypeEnum中添加类型为adVariant的每一列。

如果您需要过滤（如我一样），则解决方法如下。这应该被认为是一项正在进行的工作，因为我仅测试了我使用的功能，并且并未实现所有数据类型。自行决定使用它。

您将需要对ADO和RegEx（Microsoft VBScript正则表达式5.5）的引用。同样适用于Microsoft XML，但是如果将2个引用替换为Object类型，也应该没问题。

XML部分首先尝试使用以前的工作range.value（xlRangeValueMSPersistXML）方法进行读取，并且仅在失败的情况下使用变通方法。在XML部分中，还修复了XML方法的一个错误，即如果范围的顶部不在第1行，它将读取2个单元格作为列名。

解决方法已固定为使用第一行作为标题。它读入数据并尝试从每一列中确定数据类型。然后，它将使用该数据类型填充记录集并返回它。


    Public Function RSFromRange_XML(rngInput As Range) As ADODB.Recordset
        Dim rs As ADODB.Recordset
        Dim xlXML As MSXML2.DOMDocument60
        Dim xmlRange As String
        Dim i As Long
        Dim h As String
        Dim varArr() As Variant
        Dim MatchPattern As String
        Dim reg As RegExp
        Dim matches As MatchCollection
        Dim m As Match
        Dim lngMaxLen As Long
        Dim lngMaxLenIndex As Long

        Set reg = New RegExp
        reg.IgnoreCase = False
        reg.MultiLine = True
        reg.Global = False

        Set rs = New ADODB.Recordset
        Set xlXML = New MSXML2.DOMDocument60

        On Error Resume Next
        xmlRange = rngInput.Value(xlRangeValueMSPersistXML)
        If Err.Number <> 0 Then
            On Error GoTo 0
            Set rs = rsFromVarArr(rngInput)
            rs.MoveFirst
            GoTo ExitSuccess
        End If
        On Error GoTo 0

        varArr = rngInput.rows(1).Value

        'we ignore the column fixup when the range starts at the top of the sheet
        If rngInput.rows(1).row <> 1 Then
            For i = LBound(varArr, 2) To UBound(varArr, 2)
                'our lovely unadulterated header
                h = varArr(1, i)

                'Matches the recordset header name, our real header name, and all the garbage in between.
                MatchPattern = "rs:name=[""][^""]*" & h & "[""]"
                reg.Pattern = MatchPattern

                If reg.test(xmlRange) Then
                    xmlRange = reg.Replace(xmlRange, "rs:name=""" & h & """")
                End If
            Next i
        End If

        xlXML.LoadXML xmlRange
        rs.Open xlXML

    ExitSuccess:
        Set RSFromRange_XML = rs
    End Function


    ' This is a workaround for a bug in excel, so consider it a work in progress.
    ' It may fail in some situations, if it does, those will need to be handled.
    Public Function rsFromVarArr(rngInput As Range) As Recordset
        Dim rs As ADODB.Recordset
        Dim i As Long
        Dim j As Long
        Dim data() As Variant
        Dim header() As Variant
        Dim varArr() As Variant
        Dim arrFieldTypes() As ADODB.DataTypeEnum
        Dim arrDefinedSize() As Long
        Dim h As Variant 'ADO field workaround
        Dim record() As Variant
        Dim r As Variant 'ADO record workaround

        Set rs = New ADODB.Recordset

        'read data into var arr
        data = rngInput.Value

        'headers
        header = rngInput.rows(1).Value
        ReDim header(LBound(data, 2) To UBound(data, 2))
        For i = LBound(data, 2) To UBound(data, 2)
            header(i) = data(LBound(data, 1), i)
        Next i

        'check header col count matches data col count
        'Debug.Assert (UBound(header) - LBound(header)) = (UBound(data, 2) - LBound(data, 2))


        ' Date -> DateTime -> String -> variant
        ' Integer -> single -> double -> String -> variant
        ' boolean -> string -> variant

        ' Work out the variable types
        ReDim arrFieldTypes(LBound(header) To UBound(header))
        ReDim arrDefinedSize(LBound(header) To UBound(header))
        For i = LBound(arrFieldTypes) To UBound(arrFieldTypes)
            For j = LBound(data, 1) + 1 To UBound(data, 1)
                arrFieldTypes(i) = getCompatibleADOType(data(j, i), arrFieldTypes(i))
                If arrDefinedSize(i) < LenB(data(j, i)) Then arrDefinedSize(i) = LenB(data(j, i)) + 2
            Next j
        Next i

        'Now fix variable types
        For i = LBound(arrFieldTypes) To UBound(arrFieldTypes)
            For j = LBound(data, 1) + 1 To UBound(data, 1)
                If IsEmpty(data(j, i)) Or data(j, i) = "" Then
                    'data(j, i) = Null
                    data(j, i) = Empty
                Else
                    Select Case arrFieldTypes(i)
                        Case adBoolean: data(j, i) = CBool(data(j, i))
                        Case adUnsignedInt: data(j, i) = CByte(data(j, i))
                        Case adInteger: data(j, i) = CLng(data(j, i))
                        Case adDecimal: data(j, i) = CDec(data(j, i))
                        Case adSingle: data(j, i) = CSng(data(j, i))
                        Case adDouble: data(j, i) = CDbl(data(j, i))
                        Case adDate: data(j, i) = CDate(data(j, i))
                        Case adVarChar: data(j, i) = CStr(data(j, i))
                        Case adVarWChar: data(j, i) = CStr(data(j, i))
                        Case adVariant: data(j, i) = data(j, i)
                        Case Else
                            Debug.Assert False 'we shouldnt get here
                    End Select
                End If
                'arrFieldTypes(i) = getCompatibleADOType(data(j, i), arrFieldTypes(i))
                'If arrDefinedSize(i) < LenB(data(j, i)) Then arrDefinedSize(i) = LenB(data(j, i)) + 2
            Next j
        Next i

        'add all headers to the rs
        For i = LBound(header) To UBound(header)

            If arrFieldTypes(i) >= 200 And arrFieldTypes(i) <= 203 Then
                If arrDefinedSize(i) = 0 Then arrDefinedSize(i) = 20
                rs.Fields.append CStr(header(i)), arrFieldTypes(i), arrDefinedSize(i)
            ElseIf arrFieldTypes(i) = adEmpty Then
                rs.Fields.append CStr(header(i)), adVariant, 20
            Else
                rs.Fields.append CStr(header(i)), arrFieldTypes(i)
            End If

            If arrFieldTypes(i) = adDecimal Then
                rs.Fields(header(i)).NumericScale = 14
                rs.Fields(header(i)).Precision = 4
            End If
        Next i
        rs.CursorLocation = adUseClient
        rs.LockType = adLockPessimistic
        rs.Open

        ' ADO requires this, as it can read from a variant containing an array,
        ' but not from an array of variants!
        h = header
        ReDim record(LBound(data, 2) To UBound(data, 2))

        'Read  data 1 record at a time
        'assuming the top row is header info
        For i = LBound(data, 1) + 1 To UBound(data, 1)
            For j = LBound(data, 2) To UBound(data, 2)
                record(j) = data(i, j)
            Next j
            r = record


            rs.AddNew h, r
        Next i

        Set rsFromVarArr = rs
    End Function


    ' If no ado type is supplied, this will return the closest match to vbVar
    ' If AdoType is supplied, this will find an ado type that is compatible with both the
    ' adoType and the vbVar
    Private Function getCompatibleADOType(ByVal vbVar As Variant, Optional AdoType As ADODB.DataTypeEnum) As ADODB.DataTypeEnum
        Dim ret As ADODB.DataTypeEnum
        ' These ado types are not handled
        If AdoType = adBSTR Then AdoType = 0
        If AdoType = adEmpty Then AdoType = 0
        If AdoType = adError Then AdoType = 0
        If AdoType = adGUID Then AdoType = 0
        If AdoType = adGUID Then AdoType = 0
        If AdoType = adIDispatch Then AdoType = 0

        If AdoType = adIUnknown Then AdoType = 0
        If AdoType = adPropVariant Then AdoType = 0
        If AdoType = adUserDefined Then AdoType = 0

        'Excel promotes some types, demote them where possible.
        'we dont want ints reading as doubles, or bools reading as ints
        If IsEmpty(vbVar) Then
            ret = AdoType
            getCompatibleADOType = ret
            Exit Function
        ElseIf IsNumeric(vbVar) Then
            If vbVar = CLng(vbVar) Then
                If vbVar = 0 Or vbVar = -1 Or vbVar = 1 Then
                    vbVar = CBool(vbVar)
                Else
                    vbVar = CLng(vbVar)
                End If
            End If
        ElseIf VarType(vbVar) = vbString And (UCase(vbVar) = "TRUE" Or UCase(vbVar) = "FALSE") Then
            vbVar = CBool(vbVar)
        End If

        ' Boolean -> Integer -> Decimal -> String -> Variant
        ' Date -> String -> Variant
        ' Integer -> Decimal -> Double -> String -> Variant
        ' Single -> Double

        Select Case AdoType
            Case adBoolean
                If VarType(vbVar) = vbEmpty Then
                    ret = adBoolean
                ElseIf VarType(vbVar) = vbBoolean Then
                    ret = adBoolean
                ElseIf VarType(vbVar) = vbByte Then
                    ret = adInteger
                ElseIf VarType(vbVar) = vbInteger Then
                    ret = adInteger
                ElseIf VarType(vbVar) = vbLong Then
                    ret = adInteger
                ElseIf VarType(vbVar) = vbDecimal Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbCurrency Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbLong Then
                    ret = adInteger
                ElseIf VarType(vbVar) = vbLong Then
                    ret = adInteger

                ElseIf VarType(vbVar) = vbSingle Then
                    ret = adDouble
                ElseIf VarType(vbVar) = vbDouble Then
                    ret = adDouble
                ElseIf VarType(vbVar) = vbString And (UCase(vbVar) = "TRUE" Or UCase(vbVar) = "FALSE") Then
                    ret = adBoolean
                ElseIf VarType(vbVar) = vbString Then
                    ret = adVarWChar
                Else
                    ret = adVariant
                End If

            Case adDate
                If VarType(vbVar) = vbEmpty Then
                    ret = adDate
                ElseIf VarType(vbVar) = vbDate Then
                    ret = adDate
                ElseIf VarType(vbVar) = vbDouble Then
                    ret = adDate
                ElseIf VarType(vbVar) = vbString Then
                    ret = adVarWChar
                Else
                    ret = adVariant
                End If

            Case adUnsignedTinyInt, adSmallInt, adInteger
                If VarType(vbVar) = vbEmpty Then
                    ret = adInteger
                ElseIf VarType(vbVar) = vbBoolean Then
                    ret = adInteger
                ElseIf VarType(vbVar) = vbByte Then
                    ret = adInteger
                ElseIf VarType(vbVar) = vbInteger Then
                    ret = adInteger
                ElseIf VarType(vbVar) = vbLong Then
                    ret = adInteger
                ElseIf VarType(vbVar) = vbSingle Or VarType(vbVar) = vbDouble Then
                    If vbVar = CLng(vbVar) Then
                        ret = adInteger
                    Else
                        ret = adDouble
                    End If
                Else
                    ret = adVarWChar
                End If

            Case adBigInt
                If VarType(vbVar) = vbEmpty Then
                    ret = adBigInt
                ElseIf VarType(vbVar) = vbBoolean Then
                    ret = adBigInt
                ElseIf VarType(vbVar) = vbInteger Then
                    ret = adBigInt
                ElseIf VarType(vbVar) = vbLong Then
                    ret = adBigInt
                ElseIf VarType(vbVar) = vbSingle Or VarType(vbVar) = vbDouble Then
                    If vbVar = CLng(vbVar) Then
                        ret = adBigInt
                    Else
                        ret = adDouble
                    End If
                Else
                    ret = adVarWChar
                End If

            Case adNumeric, adDecimal, adCurrency
                If VarType(vbVar) = vbEmpty Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbBoolean Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbCurrency Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbDecimal Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbInteger Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbLong Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbSingle Or VarType(vbVar) = vbDouble Then
                    If vbVar = CLng(vbVar) Then
                        ret = adDecimal
                    Else
                        ret = adDecimal
                    End If
                Else
                    ret = adVarWChar
                End If

            Case adSingle, adDouble
                If VarType(vbVar) = vbBoolean Then
                    ret = adDouble
                ElseIf VarType(vbVar) = vbCurrency Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbDecimal Then
                    ret = adDecimal
                ElseIf VarType(vbVar) = vbInteger Then
                    ret = adDouble
                ElseIf VarType(vbVar) = vbLong Then
                    ret = adDouble
                ElseIf VarType(vbVar) = vbSingle Or VarType(vbVar) = vbDouble Then
                    If vbVar = CLng(vbVar) Then
                        ret = adDouble
                    Else
                        ret = adDouble
                    End If
                Else
                    ret = adVariant
                End If

            Case adVarWChar 
                If VarType(vbVar) = vbEmpty Then
                    ret = adVarWChar
                ElseIf VarType(vbVar) = vbString Then
                    ret = adVarWChar
                ElseIf Not IsError(CStr(vbVar)) Then
                    ret = adVarWChar
                Else
                    ret = adVariant
                End If

            Case adVariant
                ret = adVariant
            'unimplemented types
            'Case adBinary: 'raw data
            'Case adLongVarBinary 'long raw
            'Case adVarBinary 'raw data
            'Case adDBTimeStamp
            'Case adChar
            'Case adVarChar
            'Case adWChar
            'Case adLongVarWChar

            Case Else
                'ret = adVariant
                '===============================
                Select Case VarType(vbVar)
                    Case vbBoolean 'adBoolean
                        ret = adBoolean
                    Case vbByte 'adInteger
                        ret = adInteger
                    Case vbInteger: 'adInteger
                        ret = adInteger
                    Case vbLong: 'adInteger
                        ret = adInteger
                    Case vbDecimal 'adDecimal
                        ret = adDecimal
                    Case vbCurrency 'adDecimal
                        ret = adDecimal
                    Case vbSingle 'adSingle
                        ret = adSingle
                    Case vbDouble 'adDouble
                        ret = adDouble

                    Case vbDate 'adDate
                        ret = adDate
                        'ret = adDBTimeStamp
                    Case vbString 'adVarWChar
                        ret = adVarWChar

                    Case vbError 'adError
                        ret = adEmpty
                    'Case vbVariant 'adVariant
                    '    ret = adVariant
                    Case vbEmpty ' Null equiv
                        ret = adEmpty
                    Case vbNull ' Null equiv
                        ret = adEmpty
                    Case vbObject
                        ret = adIDispatch
                    Case vbDataObject
                        ret = adIUnknown
                    Case vbArray 'We dont want to be getting here
                        Debug.Assert False
                        ret = adArray

                    Case Else
                        ret = adVariant
                End Select
                '===============================
        End Select

        If ret = 0 Then ret = adEmpty
        getCompatibleADOType = ret
    End Function

Answer 3

请参阅以下针对此问题的解决方法，该函数作为一个函数根据指定的输入范围返回记录集。我用它替换了代码中的旧XML方法，结果记录集似乎具有相同的功能，即它支持过滤和排序。

希望这会有所帮助！

Function rng2ADOR(rng As Range) As ADODB.Recordset

    If rng Is Nothing Then Exit Function

    Dim sConnection As String
    Dim sSQL As String

    sConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & rng.Worksheet.Parent.FullName & ";Extended Properties=Excel 12.0"

    sSQL = "SELECT * FROM [" & rng.Worksheet.Name & "$" & rng.Address(False, False) & "]"

    Set rng2ADOR = New ADODB.Recordset

    'allow local ador cursor to be used independently to source
    rng2ADOR.CursorLocation = adUseClient

    'open static & read-only ADOR
    rng2ADOR.Open sSQL, sConnection, adOpenStatic, adLockReadOnly

End Function

Answer 4

Range.value（xlRangeValueMSPersistXML）不再起作用是不完全正确的。

更新后，xlRangeValueMSPersistXML的工作原理有所不同。特别是它对数字单元格值敏感。

它假定数字单元格的值是一种整数；如果它们加倍，则失败。文本单元格没有问题。我只用一个单元格尝试过，它根据包含的值工作。

事实上，它现在创建了这样的XML：

对于文本单元格：

    <xml xmlns:x="urn:schemas-microsoft-com:office:excel"
 xmlns:dt="uuid:C2F41010-65B3-11d1-A29F-00AA00C14882"
 xmlns:s="uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882"
 xmlns:rs="urn:schemas-microsoft-com:rowset" xmlns:z="#RowsetSchema">
 <x:PivotCache>
  <x:CacheIndex>1</x:CacheIndex>
  <s:Schema id="RowsetSchema">
   <s:ElementType name="row" content="eltOnly">
    <s:attribute type="Col1"/>
    <s:extends type="rs:rowbase"/>
   </s:ElementType>
   <s:AttributeType name="Col1" rs:name="Field1">
    <s:datatype dt:maxLength="255"/>
   </s:AttributeType>
  </s:Schema>
  <rs:data>
   <z:row Col1="A TEST"/>
  </rs:data>
 </x:PivotCache>
</xml>

和数字

    <xml xmlns:x="urn:schemas-microsoft-com:office:excel"
 xmlns:dt="uuid:C2F41010-65B3-11d1-A29F-00AA00C14882"
 xmlns:s="uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882"
 xmlns:rs="urn:schemas-microsoft-com:rowset" xmlns:z="#RowsetSchema">
 <x:PivotCache>
  <x:CacheIndex>1</x:CacheIndex>
  <s:Schema id="RowsetSchema">
   <s:ElementType name="row" content="eltOnly">
    <s:attribute type="Col1"/>
    <s:extends type="rs:rowbase"/>
   </s:ElementType>
   <s:AttributeType name="Col1" rs:name="Field1">
    <s:datatype dt:type="int"/> <---- The culprit!!! It was dt:type="Number" before...
   </s:AttributeType>
  </s:Schema>
  <rs:data>
   <z:row Col1="460251"/>
  </rs:data>
 </x:PivotCache>
</xml>

更改之处在于，现在它使用<s:datatype dt:type="int"/>，而在更新之前它使用<s:datatype dt:type="Numeric"/>

可能int并不完全意味着0-32768。我注意到它在较大值的单元格（例如2206484）下失败了。因此，大概在更新之后，我们将需要在加载XML数据之前定义XML数据结构。目前，我还不知道该怎么做，但是可能我们将需要一种诸如 numberformat 之类的技巧。此外，在多次错误消息传递测试了单元格中的值之后，我得到了：

运行时错误：'-2147417848（80010108）自动化错误调用的对象已与其客户端断开连接

我不再需要从几秒钟前读取的单元格中获取XML值。

我认为我们已经接近解决方法。

更新后，Excel的Range.Value属性不再与xlRangeValueMSPersistXML参数一起使用

4 个答案: