0

3/30 更新

所以我调整了代码，它现在运行没有错误，但问题是它没有提取正确的数据。X 基本上以 cell(X,1) 开始并从那里继续。如何将 X 链接到数组中选定的列表框选项？

旧消息： 我有一个用户表单，允许多选国家以及有关该特定国家的问题。这些分别存储在 arrCountries 和 arrQuestion 中。然后，这将提供给我的主子程序，该子程序需要从 CIA World Factbook 站点进行 Web 查询导入。但是，我不断收到一个不匹配的错误，我似乎无法弄清楚如何解决：

黄色不匹配错误

如果我不得不猜测，那是因为当我从列表框填充数组时，它只是添加了一个字符串，而不是该字符串所在的单元格引用（或者我完全错了）。

我的工作表在开始时只有一张名为 Country 的工作表，A 列是 URL，B 列是国家名称。我已将 Public arrCountry()、Public arrQuestion() 和 Public X 定义为变体。

代码在这里：

单击确定时的用户表单代码：

'Handles when the user clicks okay
Private Sub cbOkay_Click()
    'Me.Hide
'Capture ticker selection(s) from list box.
Dim cI As Long
Dim cX As Long
Dim qI As Long
Dim qX As Long

'Stores the Countries selected into an array
If lbCountries.ListIndex <> -1 Then
    For cI = 0 To lbCountries.ListCount - 1
        If lbCountries.Selected(cI) Then
            ReDim Preserve arrCountry(cX)
            arrCountry(cX) = lbCountries.List(cI)
            cX = cX + 1
        End If
    Next cI
End If

If cX = 0 Then MsgBox "Please select at least one country to analyse."
'MsgBox Join(arrCountry, vbCrLf)

'Stores the Questions selected into an array
If lbQuestions.ListIndex <> -1 Then
    For qI = 0 To lbQuestions.ListCount - 1
        If lbQuestions.Selected(qI) Then
            ReDim Preserve arrQuestion(qX)
            arrQuestion(qX) = lbQuestions.List(qI)
            qX = qX + 1
        End If
    Next qI
End If

If qX = 0 Then MsgBox "Please select at least one question to analyse."

'MsgBox Join(arrQuestion, vbCrLf)

'Unload the form
Unload Me

cancel = False
End Sub

消息框返回正确选择的列表框项目，因此我知道它们被正确存储。

我收到错误的 WebQuery 代码：

更新代码：

所以我添加了一个循环计数器：

Sub webQueryimport(arrCountry())

Dim mystr As String
Dim X As Integer
Dim selected As Variant

For Each selected In arrCountry
    X = X + 1
Worksheets("Countries").Select
Worksheets("Countries").Activate
     mystr = Cells(X, 1)
     Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = selected

        With ActiveSheet.QueryTables.Add(Connection:=mystr, Destination:=Range("$A$1"))
            .WebSelectionType = xlEntirePage 'this tells VBA what to select and import
            .WebFormatting = xlWebFormattingNone 'this turns off web formatting, otherwise text is various sizes
            .Refresh BackgroundQuery:=False 'if commented out, doesn't add any data
        End With
Next selected

End Sub

同样，现在该循环可以工作并将导入，但无论在列表框和 arrCountries 中选择什么，它总是以 A1 开头

任何想法/帮助都会很棒！

4

1 回答 1

0

知道了：

Sub webQueryimport(arrCountry())

Dim mystr As String
Dim X As Integer
Dim rng As Range
Dim selected As Variant

Set rng = Range("B1")

For Each selected In arrCountry()
    For X = 1 To 5 'rng.Offset(0, 0).End(xlDown).Rows.count
        Worksheets("Countries").Select
        Worksheets("Countries").Activate

        If Cells(X, 2).Value = selected Then
            mystr = Cells(X, 1).Value
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = selected

            With ActiveSheet.QueryTables.Add(Connection:=mystr, Destination:=Range("$A$1"))
                .WebSelectionType = xlEntirePage 'this tells VBA what to select and import
                .WebFormatting = xlWebFormattingNone 'this turns off web formatting, otherwise text is various sizes
                .Refresh BackgroundQuery:=False 'if commented out, doesn't add any data
            End With
        End If
      Next X
    Next selected
End Sub

我需要添加一个计数器和 IF 语句来检查数组中的值是否与工作表中的单元格值匹配，然后返回适当的单元格以进行导入。

于 2017-03-31T12:44:53.110 回答