Свойство Range.Value в Excel больше не работает с параметром xlRangeValueMSPersistXML после обновления

Question

После недавнего обновления Windows / Office свойство Range.Value в Excel, похоже, не работает при передаче параметра xlRangeValueMSPersistXML, который сообщает свойству 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

Не совсем верно, что 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.На данный момент я не знаю, как это сделать, но, вероятно, нам понадобится такая хитрость, как числовой формат или что-то еще.Более того, после нескольких сообщений об ошибках, проверяя значения в ячейках, которые я получил:

Ошибка времени выполнения: '-2147417848 (80010108) Ошибка автоматизации Вызванный объект отключился от своего клиента

и у меня больше не было возможности получать значения XML из ячеек, которые я читал несколько секунд назад.

Я думаю, что мы находимся в обходном пути.

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

Для тех, кто не хочет откатываться назад или не может сделать это, я начал обходной путь.Он будет использовать предыдущий метод, если он работает, поэтому он будет фактически запускать обходной путь на тех машинах, у которых есть проблема.

Если фильтрация не требуется, вы можете просто создать свой собственный набор записей и добавить каждый столбец с помощьювведите adVariant из ADODB DataTypeEnum.

Если вам нужна фильтрация (как я), то обходной путь находится ниже.Это должно считаться незавершенным, поскольку я проверил только те функции, которые я использую, и он не реализует все типы данных.Используйте его по своему усмотрению.

Вам понадобятся ссылки на ADO и RegEx (регулярные выражения Microsoft VBScript 5.5).Также для Microsoft XML, но если вы замените 2 ссылки на тип Object, то с этим тоже должно быть все в порядке.

Раздел XML сначала пытается прочитать, используя ранее работающий метод range.value (xlRangeValueMSPersistXML), и использует толькоОбходной путь, если это не удается.В разделе XML есть также исправление ошибки в методе XML, когда он читает 2 ячейки для имени столбца, если верхняя часть диапазона не находится в строке 1.

Обходной путь исправлен на использованиеверхний ряд как заголовки.Он считывает данные и пытается определить тип данных для каждого столбца.Затем он использует этот тип данных, чтобы заполнить набор записей и вернуть его.

    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