Скрипты VBA: QueryTable в цикле не оставляет полученный текст в ячейке - PullRequest
Новая
       19

Скрипты VBA: QueryTable в цикле не оставляет полученный текст в ячейке

0 голосов
/ 05 августа 2011

VBA noob здесь (только начал использовать его вчера) в Excel 2007, и я пытаюсь сопоставить имена пользователей с полными именами, используя QueryTables и цикл.

Я сделал большую часть этого, просто во время работы он правильно заполняет ячейку, но когда он попадает в следующую ячейку, он очищает содержимое ячейки над ней. По сути, я вижу имена, «путешествующие» вниз по списку, и в конце у меня просто одно имя в самом низу.

Мой стол начинается так: 

| user name | full name  |
| psmith    |            |
| duane     |            |
| susanl    |            |

Моя таблица должна выглядеть следующим образом после запуска макроса: 

| user name | full name     |
| psmith    | Peter Smith   |
| duane     | Duane Roberts |
| susanl    | Susan Li      |

Но вместо этого я получаю это во время работы (представьте, что это похоже на анимацию): 

| user name | full name     |
| psmith    | Peter Smith   |
| duane     |               |
| susanl    |               |

| user name | full name     |
| psmith    |               |
| duane     | Duane Roberts |
| susanl    |               |

| user name | full name     |
| psmith    |               |
| duane     |               |
| susanl    | Susan Li      |

Мой код выглядит так: 

Dim rngUserName As Range
Dim userName As String

Set rngUserName = ActiveSheet.Range("D2")

Do Until IsEmpty(rngUserName.Offset(0, -1))
    userName = rngUserName.Offset(0, -1).Value
    With Worksheets(1).QueryTables.Add(Connection:= _
        "URL;http://mysite.com/scripts/cgi-bin/map_name.cgi?" & userName, _
        Destination:=rngUserName)
        .Name = "map_name.cgi?" & userName & "_1"
        .FieldNames = False
        .RowNumbers = False
        .FillAdjacentFormulas = True
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlAllTables
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = False
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery = True
    End With

    Set rngUserName = rngUserName.Offset(1, 0)
Loop

Почему извлеченный текст не прилипает ?? Это сводит меня с ума, и Google не помогает ...

Спасибо !!

Ответы [ 2 ]

3 голосов
/ 05 августа 2011

Вот альтернативный подход без таблиц запросов: 

Sub Tester()
  Const URL as string = "http://mysite.com/scripts/cgi-bin/map_name.cgi?"
  Dim userName as string 
  Dim rngUserName as range   

  Set rngUserName = ActiveSheet.Range("B2") 

  Do Until IsEmpty(rngUserName.Offset(0, -1))          
    userName = rngUserName.Offset(0, -1).Value         
    rngUserName.Value = WebResponse(URL & userName)
    Set rngUserName = rngUserName.Offset(1, 0)      
  Loop 
End sub


Private Function WebResponse(URL As String) As String
    Dim XmlHttpRequest As Object
    Set XmlHttpRequest = CreateObject("MSXML2.XMLHTTP")
    XmlHttpRequest.Open "GET", URL, False
    XmlHttpRequest.send
    WebResponse = XmlHttpRequest.responseText
End Function
1 голос
/ 05 августа 2011

Ваша переменная rRow не соответствует Activecell.Лучше также избегать выбора, если можете. 

Dim userName as string
Dim rngUserName as range


Set rngUserName = ActiveSheet.Range("B2")
Do Until IsEmpty(rngUserName.Offset(0, -1))     

   userName = rngUserName.Offset(0, -1).Value     
   With Worksheets(1).QueryTables.Add(Connection:= _         
      "URL;http://mysite.com/scripts/cgi-bin/map_name.cgi?" & userName, _
       Destination:=rngUserName)         
    .Name = "map_name.cgi?" & userName & "_1"         
    '....         
    .Refresh BackgroundQuery:=False     
   End With     

   Set rngUserName = rngUserName.Offset(1, 0)    

Loop
...