EXCEL – VBA。 获取单元值作为键值对

我正在尝试从“I”列的Excel单元格中获取地址值，并将其作为查询string传递给使用VBA的URL。 在Excel里面embedded了“Microsoft Object Browser”加载页面。

这甚至有可能吗？ 因为我担心查询string太高（近似1000行）传递的数据量。

代码是不工作，有没有办法通过传递查询string作为数组呢？

另外我需要VBA语法来parsing字典值。

我是VBA新手。 请帮忙。

Dim Arr() As Variant ' declare an unallocated array. Arr = Range("I:I") ' Arr is now an allocated array Set dict = CreateObject("Scripting.Dictionary") Dim iRow As Integer iRow = 1 Dim parms As Variant Dim rg As Range For Each rg In Sheet1.Range("I:I") ' Print address of cells that are negative 'MsgBox (rg.Value) 'result = result & rg.Value dict.Add rg.Value iRow = (iRow + 1) Next MsgBox (dict.Item(1)) Set dict = Nothing 'WebBrowser1.Navigate2 "http://localhost/excelmaps/maps.php?adr=" & parms End Sub 

Answer 1

看来IE的最大URL长度是2083个字符：

https://support.microsoft.com/en-us/kb/208427

build立查询我会使用一个string生成器（“System.Text.StringBuilder”）。 您还需要对所有参数进行URL编码。

以下是一个范例[A1：B10]中的名称/值构buildurl的示例：

 Sub BuildURL ' Read the names/values from a sheet Dim names_values() names_values = [A1:B10].Value2 ' Create a string builder Dim sb As Object Set sb = CreateObject("System.Text.StringBuilder") sb.Append_3 "http://localhost/excelmaps/maps.php" ' Build the query Dim i&, name$, value$ For i = 1 To UBound(names_values) name = names_values(i, 1) value = names_values(i, 2) If i = 1 Then sb.Append_3 ("?") Else sb.Append_3 ("&") sb.Append_3 URLEncode(name) ' Adds the name sb.Append_3 "=" sb.Append_3 URLEncode(value) ' Adds the value Next ' Print the result Debug.Print sb.ToString() End Sub Public Function URLEncode(url As String, Optional space_to_plus As Boolean) As String Static ToHex(15), IsLiteral%(127), buffer() As Byte, bufferCapacity& Dim urlBytes() As Byte, bufferLength&, i&, u&, b&, space& If space_to_plus Then space = 32 Else space = -1 If bufferCapacity = 0 Then GoSub InitializeOnce urlBytes = url For i = 0 To UBound(urlBytes) Step 2 If bufferLength >= bufferCapacity Then GoSub IncreaseBuffer u = urlBytes(i) + urlBytes(i + 1) * 256& If u And -128 Then ' U+0080 to U+1FFFFF ' If u And -2048 Then ' U+0800 to U+1FFFFF ' If (u And 64512) - 55296 Then ' U+0800 to U+FFFF ' b = 224 + (u \ 4096): GoSub WriteByte b = 128 + (u \ 64 And 63&): GoSub WriteByte b = 128 + (u And 63&): GoSub WriteByte Else ' surrogate U+10000 to U+1FFFFF ' i = i + 2 u = ((urlBytes(i) + urlBytes(i + 1) * 256&) And 1023&) _ + &H10000 + (u And 1023&) * 1024& b = 240 + (u \ 262144): GoSub WriteByte b = 128 + (u \ 4096 And 63&): GoSub WriteByte b = 128 + (u \ 64 And 63&): GoSub WriteByte b = 128 + (u And 63&): GoSub WriteByte End If Else ' U+0080 to U+07FF ' b = 192 + (u \ 64): GoSub WriteByte b = 128 + (u And 63&): GoSub WriteByte End If ElseIf IsLiteral(u) Then ' unreserved ascii character ' buffer(bufferLength) = u bufferLength = bufferLength + 2 ElseIf u - space Then ' reserved ascii character ' b = u: GoSub WriteByte Else ' space character ' buffer(bufferLength) = 43 ' convert space to + ' bufferLength = bufferLength + 2 End If Next URLEncode = LeftB$(buffer, bufferLength) Exit Function WriteByte: buffer(bufferLength) = 37 '% buffer(bufferLength + 2) = ToHex(b \ 16) buffer(bufferLength + 4) = ToHex(b And 15&) bufferLength = bufferLength + 6 Return IncreaseBuffer: bufferCapacity = UBound(buffer) * 2 ReDim Preserve buffer(bufferCapacity + 25) Return InitializeOnce: bufferCapacity = 2048 ReDim buffer(bufferCapacity + 25) For i = 0 To 9: ToHex(i) = CByte(48 + i): Next '[0-9]' For i = 10 To 15: ToHex(i) = CByte(55 + i): Next '[AF]' For i = 48 To 57: IsLiteral(i) = True: Next '[0-9]' For i = 65 To 90: IsLiteral(i) = True: Next '[AZ]' For i = 97 To 122: IsLiteral(i) = True: Next '[az]' IsLiteral(45) = True ' - ' IsLiteral(46) = True ' . ' IsLiteral(95) = True ' _ ' IsLiteral(126) = True ' ~ ' Return End Function 

Answer 2

有很多事情，所以我只是试图解决字典部分，因为这是你所标记的。

首先用字典，你可以添加一个项目如下：

 dict(“your key”) = “your value” 

我发现你已经正确设置了字典，并且在运行你的代码之前，一定要在VBA编辑器中添加字典引用（转到Tools-> References-> Microsoft Scripting Runtime） 。

在这种情况下，它看起来像你的键值是增量整数。 那么为什么不使用一个数组，如下面的代码？

另一个问题是循环整个列（全部> 100万行）会导致溢出错误。 也许开始手动指定要在for循环中循环的行（请参阅“rowsToLoop”variables）：

 Sub der() Dim rowsToLoop As Integer rowsToLoop = 1000 Dim Arr() As Variant 'define empty array ReDim Arr(rowsToLoop) 'redefine with variable length Dim dict As Dictionary Set dict = CreateObject("Scripting.Dictionary") Dim x As Integer For x = 1 To rowsToLoop 'With an array Arr(x - 1) = Sheet1.Range("I1").Cells(x, 1).Value 'note array index starts at 0 'With a dictionary dict(x - 1) = Sheet1.Range("I1").Cells(x, 1).Value Next x MsgBox "This is from array: " & Arr(1) MsgBox "This is from dictionary: " & dict(1) End Sub