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

Question

我想从列'I'的Excel单元格中获取地址值，并将其作为查询字符串传递给使用VBA的URL。在Excel中嵌入了“Microsoft Object Browser”来加载页面。

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

虽然代码不工作，有没有什么办法可以通过传递查询字符串作为数组呢？

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

我是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

要构建查询，我会使用字符串构建器（“System.Text.StringBuilder”）。 您还需要对所有参数进行URL编码。

下面是一个例子从范围内建设有名称/值的网址[A1：B10]：

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 '[A-F]' 
    For i = 48 To 57: IsLiteral(i) = True: Next '[0-9]' 
    For i = 65 To 90: IsLiteral(i) = True: Next '[A-Z]' 
    For i = 97 To 122: IsLiteral(i) = True: Next '[a-z]' 
    IsLiteral(45) = True ' - ' 
    IsLiteral(46) = True ' . ' 
    IsLiteral(95) = True ' _ ' 
    IsLiteral(126) = True ' ~ ' 
    Return 
End Function 

Answer 2

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

使用词典

首先，你可以添加如下项目：

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

我看你已经正确设置了字典，并始终确保运行代码前加在VBA编辑字典参考（转到工具 - >参考 - > Microsoft脚本运行时）。

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

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

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