在用户名和登录名后使用Excel VBA获取表

Question

我正在尝试从网站获取表格。 问题是我需要先登录才能访问此信息。

我的代码如下。 我遇到了障碍，我在那里找到的大多数指南都不适用于该站点。 感谢您的帮助。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

    ' The variable KeyCells contains the cells that will cause an alert when they are changed.
    Set KeyCells = Range("H1")

    If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
            ' Clear contents of Sheet 1
            '
            Worksheets("Sheet1").Cells.Clear
            Range("A1").Select
            '
            'Login to the website
            '
            Dim IE As Object

            Set IE = CreateObject("InternetExplorer.application")

            With IE
                .Visible = True
                .navigate ("https://www.gurufocus.com/forum/login.php?0")

                While .Busy Or .readyState <> 4: DoEvents: Wend

                .document.all("Template_GLE_Login_LoginView1_login_UserName").Focus
                .document.all("Template_GLE_Login_LoginView1_login_UserName").Value = "Username"
                .document.all("Template_GLE_Login_LoginView1_login_Password").Focus
                .document.all("Template_GLE_Login_LoginView1_login_Password").Value = "Password"
                .document.all("Template_GLE_Login_LoginView1_login_LoginButton").Click

                While .Busy Or .readyState <> 4: DoEvents: Wend
                Debug.Print .LocationURL
            End With
            '
            ' take the Ticker in sheet Blank cell H1
            Dim Ticker As String
            Ticker = Sheets("Blank").Range("H1")
            URL = "URL;http://www.gurufocus.com/financials/" & Ticker
        '
        ' get the data from the website
            Range("A1").Select
            With Sheets("Sheet1").QueryTables.Add(Connection:=URL, Destination:=Sheets("Sheet1").Range("$A$1"))
        '        .CommandType = 0
                .Name = Ticker
                .FieldNames = True
                .RowNumbers = False
                .FillAdjacentFormulas = False
        '        .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .AdjustColumnWidth = True
        '        .RefreshPeriod = 0
        '        .WebSelectionType = xlSpecifiedTables
        '        .WebFormatting = xlWebFormattingNone
        '        .WebTables = """Rf"""
        '        .WebPreFormattedTextToColumns = True
        '        .WebConsecutiveDelimitersAsOne = True
        '        .WebSingleBlockTextImport = False
        '        .WebDisableDateRecognition = False
        '        .WebDisableRedirections = False
                .Refresh BackgroundQuery:=False
            End With

    End If
End Sub

Answer 1

首先，我建议您尽快退出Worksheet_Change事件宏。 当您陷入困境时，处理长度例程并启动InternetExplorer对象以抓取Web数据是最慢的事情之一，这一切都会出错。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

    Set KeyCells = Range("H1")
    If Not Application.Intersect(KeyCells, Target) Is Nothing Then
        On Error GoTo bm_Safe_Exit
        Application.EnableEvents = False

        Worksheets("Sheet1").Cells.Clear
        'if this is Sheet1's Worksheet_Change then the following
        'would be more succinct and acknowledges that we are in Sheet1's bailywick
        'Me.Cells.Clear

        'Range("A1").Select try to work without .Select

        'allow 1 second to get out of the Worksheet_Change
        Application.OnTime Now + TimeSerial(0, 0, 1), "process_Web_Data"

    End If
bm_Safe_Exit:
    Application.EnableEvents = True
End Sub

因此，所有要做的就是捕获并评估事件。 如果涉及到H1，它将清除Sheet1并启动一个公共子目录（存储在Module表中），然后退出Dodge。 子启动仅在计划后几秒钟内完成，应该有足够的时间退出事件宏。

在模块表中：

我将Microsoft HTML对象库和Microsoft Internet控件添加到VBE的“工具”►“引用”中，以获取以下代码。

Sub process_Web_Data()
    Dim ie As New SHDocVw.InternetExplorer
    With ie
        .Visible = True
        .navigate "https://www.gurufocus.com/forum/login.php?0"

        While .Busy Or .readyState <> 4: DoEvents: Wend

        With .document
            .getelementbyid("txt-username").Value = "Username"
            .getelementbyid("txt-password").Value = "Password"
            .getelementbyid("login_form").submit
        End With

        While .Busy Or .readyState <> 4: DoEvents: Wend
        Debug.Print .LocationURL

        '-----------------
        'do all of your other stuff here
        '-----------------
    End With

End Sub

这足以使登录页面的“找不到电子邮件/用户名/密码或密码无效”。 请再试一次。' 屏幕，以便登录过程正常进行； 只是没有凭据。

至于从该公共子目录引用Sheet1，可以使用Worksheet.CodeName属性 ， Worksheet.Name属性或Worksheet.Index属性 。 我可能会选择代号。