使用Excel VBA获得一个表用户名和login名
我正试图从一个网站获得一张桌子。 问题是我需要先login才能访问这些信息。
我的代码如下。 我遇到了一个路障，我发现的大部分指南都不适用于这个网站。 感谢你的帮助。
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 首先，我build议您尽快离开Worksheet_Change事件macros。 各种各样的事情可能会出错，而你卡在那里处理一个长度的例程，启动一个InternetExplorer对象来抓取networking数据是最慢的。
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并启动一个公共子文件（存储在一个模块工作表中），然后离开道奇。 次级发射在计划之后是很短的一秒，应该有足够的时间退出事件macros。
在模块表中：
我添加了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
这足以让页面的login'该电子邮件/用户名/密码找不到或不活动。 请再试一次。' 屏幕，所以login过程正在工作; 只是不是凭证。
至于从该公共子引用Sheet1，可以使用Worksheet.CodeName属性 ， Worksheet.Name属性或Worksheet.Index属性 。 我可能会select代号。