在最近的Windows/Office更新之后，Excel的范围。通过XLRANGEVALUEMSPERSISTXML参数，Value属性似乎不起作用，该参数告诉范围的值属性以XML格式返回范围数据。还有其他人遇到这个问题吗？
这是我的代码(归功于https://usefulgyaan.wordpress.com/2013/07/11/vba-trick-of-theek-theek-theek-range-range-to-recordset-without-without-making-making-connection/(
Set adoRecordset = CreateObject("ADODB.Recordset")
Set xlXML = CreateObject("MSXML2.DOMDocument")
xlXML.LoadXML rng.Value(xlRangeValueMSPersistXML) <- this fails now
adoRecordset.Open xlXML
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阀。
我认为我们接近解决方法。
我遇到了同样的问题。我有相同的代码行并获取运行时错误："错误号-2147417848，方法'对象'范围'的value"失败。这发生在最新的Excel Update之后。
。我还没有找到解决方案，但确实设法通过回滚到上一个版本来解决问题。
在CNET帖子中修复一些错别字设法回滚。
打开一个高架命令窗口并更改为目录：
cd %programfiles%Common FilesMicrosoft SharedClickToRun
officec2rclient.exe /update user updatetoversion=16.0.11425.20244
这是Office 365的每月发行频道的最后一个版本。？redirectsourcepath =％252fen-us％252Farticle％252FAE942449-1FCA-4484-898B-A9333EA23DEF7
在Excel中，您需要转到File->Account->Update Options并关闭更新。不是最佳的，但比重写我的代码之前要好。
对于那些不想退回办公室或无法做到的人，我已经开始解决方法。如果工作起作用，它将使用以前的方法，因此它将仅在具有问题的机器上实际运行解决方法。
如果不需要过滤，您只需创建自己的记录集，并与Adodb DatatyPeenum的类型Advariant添加每列。
如果您需要过滤(就像我一样(，则解决方法在下面。由于我仅测试了我使用的功能，因此应该认为这是一项正在进行的工作，并且没有实现所有数据类型。
自己使用它。您将需要引用ADO和REGEX(Microsoft VBScript Prinesion Expressions 5.5(。也要到Microsoft XML，但是如果您将2个引用替换为类型对象，也应该很好。
XML部分首先尝试使用先前的工作范围(XlrangeValuemSperSistxml(方法读取，并且仅在失败时才使用解决方法。在XML部分中，还有一个使用XML方法的错误修复程序，如果该范围的顶部不在第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
请参阅下面的我的解决方案，作为一个基于指定输入范围返回记录集的函数。我将代码中的旧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