Question

此代码基本上正常工作但由于某种原因，它所提取的数据不会改变。当我逐步浏览Name_of_Person变量时，当我在X中移动时，每次创建和使用的URL都会发生变化，但它会继续插入第一个查询中的数据。有什么想法吗？

 Sub Search_People()

Dim Name_Of_Person As String
Dim URL As String
Dim Dashboard_Sheet As Worksheet
Set Dashboard_Sheet = ThisWorkbook.Sheets("Dashboard")
Dim Data_Sheet As Worksheet
Set Data_Sheet = ThisWorkbook.Sheets("Data")
Dim Data_Dump As Worksheet
Set Data_Dump = ThisWorkbook.Sheets("DataDump")
Dim X As Integer
Dim Y As Integer
Dim Last_Row As Long
Dim Email_Output As Range
Set Email_Output = Data_Dump.Range("A:A")
Dim Cell As Range

Last_Row = Data_Sheet.Cells(Data_Sheet.Rows.Count, 8).End(xlUp).Row

    For X = 1 To Last_Row + 1
        Name_Of_Person = Data_Sheet.Cells(2 + X, 8)
        URL = "URL;" & "https://hn.com/people/"
        URL = URL & Name_Of_Person & "%40.com"
            With Data_Dump.QueryTables.Add(Connection:= _
            URL, _
            Destination:=Data_Dump.Range("A1"))
             .FieldNames = True
             .RowNumbers = False
             .FillAdjacentFormulas = False
             .PreserveFormatting = True
             .RefreshOnFileOpen = False
             .BackgroundQuery = True
             .RefreshStyle = xlInsertDeleteCells
             .SavePassword = False
             .SaveData = True
             .AdjustColumnWidth = True
             .RefreshPeriod = 0
             .WebSelectionType = xlEntirePage
             .WebFormatting = xlWebFormattingNone
             .WebPreFormattedTextToColumns = True
             .WebConsecutiveDelimitersAsOne = True
             .WebSingleBlockTextImport = False
             .WebDisableDateRecognition = False
             .WebDisableRedirections = False
             .Refresh BackgroundQuery:=False

            Set Cell = Email_Output.Find("Email")
            Worksheets("Data").Cells(2 + X, 9).Value = Cell
            End With
            Data_Dump.Columns("A:A").Select
            Selection.Delete Shift:=xlToLeft



    Next X

End Sub

Answer 1

Sub Search_People()

Dim Name_Of_Person As String
Dim URL As String
Dim Dashboard_Sheet As Worksheet
Set Dashboard_Sheet = ThisWorkbook.Sheets("Dashboard")
Dim Data_Sheet As Worksheet
Set Data_Sheet = ThisWorkbook.Sheets("Data")
Dim Data_Dump As Worksheet
Set Data_Dump = ThisWorkbook.Sheets("DataDump")
Dim X As Integer
Dim Y As Integer
Dim Last_Row As Long
Dim Email_Output As Range
Set Email_Output = Data_Dump.Range("A:XFD")
Dim Cell As Range


Application.EnableCancelKey = xlDisabled
Last_Row = Data_Sheet.Cells(Data_Sheet.Rows.Count, 8).End(xlUp).Row

    For X = 1 To Last_Row
    On Error Resume Next

        Name_Of_Person = Data_Sheet.Cells(2 + X, 8)
            Application.StatusBar = "    Pulling Data for... " & Name_Of_Person
        URL = "URL;" & "https://site/"
        URL = URL & Name_Of_Person & "site.com"
            With Data_Dump.QueryTables.Add(Connection:= _
            URL, _
            Destination:=Data_Dump.Range("A1"))
             .FieldNames = True
             .RowNumbers = False
             .FillAdjacentFormulas = False
             .PreserveFormatting = True
             .RefreshOnFileOpen = False
             .BackgroundQuery = True
             .RefreshStyle = xlInsertDeleteCells
             .SavePassword = False
             .SaveData = True
             .AdjustColumnWidth = True
             .RefreshPeriod = 0
             .WebSelectionType = xlEntirePage
             .WebFormatting = xlWebFormattingNone
             .WebPreFormattedTextToColumns = True
             .WebConsecutiveDelimitersAsOne = True
             .WebSingleBlockTextImport = False
             .WebDisableDateRecognition = False
             .WebDisableRedirections = False
             .Refresh BackgroundQuery:=False


            End With
            Set Cell = Email_Output.Find("Email")
            Worksheets("Data").Cells(2 + X, 9).Value = Cell
            Data_Dump.Range("A:A").EntireColumn.Delete



    Next X
            Application.StatusBar = False
End Sub

此代码解决了上述所有问题。

网站上的数据将变量名称传递给URL但未转到正确的网站

1 个答案: