EXCEL - VBA . Getting the cell values as Key Value Pairs

Question

I am trying to get an address values from excel cells of column 'I' and pass it as a query string to the URL using VBA. Have embedded 'Microsoft Object Browser' inside the excel to load the page.

Is this even possible? because i am worried about the amount of data passed as query string is too high (1000 rows approximate).

The code is not working though, is there any way i could do the same by passing the query string as array?

Also i need VBA syntax to parse the dictionary values.

I am new to VBA. Please Help.

    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

It seems that the maximum URL length for IE is 2083 characters:

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

To build the query I would use a string builder ("System.Text.StringBuilder"). You also need to URL encode all the arguments.

Here is an example building an url with the names/values from range [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

There’s quite a bit going on, so I’ll just try to address the dictionary part since that’s what you’ve tagged.

Firstly with dictionaries, you can add an item as follows:

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

I see you’ve set the dictionary correctly, and always be sure to add the dictionary reference in VBA editor before running your code (go to Tools->References-> Microsoft Scripting Runtime).

In this case, it looks like your key values are incremental integers. So why not just use an array, as in the code below?

The other issue is that looping an entire column (all > 1 million rows) gives an overflow error. Maybe start off manually specifying the rows to loop in a for loop (see the “rowsToLoop” variable):

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