我的excel VBA报废代码有什么问题。 [英] What is the problem with my excel VBA scrapping code.

问题描述

大家好。我正在尝试从网站上删除数据到excel文件。

这里的路线想法。



从startrow到stoprow的行。



导航到链接可以从一个单元格中获取的网站。

收集信息并保存回excel。 />
下一页



我每次只能运行30行然后IE崩溃或IE忙的问题我必须停止并手动重新运行。



请帮忙。



我的尝试：

 Sub UpdateProjectListV2（startRow As Long，StopRow As Long）
 Application.ScreenUpdating = False 
 Application.DisplayAlerts = False 
 Application.EnableEvents = False 
 Application.Calculation = xlCalculationManual 
 
 Dim BaseWorkbook As Workbook 
 Set BaseWorkbook = ThisWorkbook 
 Dim FuncUpdateBid，FuncPStatus，FuncProCountry，FuncProBudget， SDATE 1 As String 
 Dim DeleteP As Object 
 Dim NumbidElem As IHTMLElement 
 Dim i，iTotalRows As Long 
 Dim stemp As String 
 iTotalRows = BaseWorkbook.Worksheets（Project Info ）。范围（B：B）。Cells.SpecialCells（xlCellTypeConstants）.Count 
 sDate1 =格式（Now（），mmm dd，yyyy）
 Dim appIE As InternetExplorer 
设置appIE = CreateObject（internetexplorer.application）
 For i = startRow To StopRow 
 with appIE 
 .navigate BaseWorkbook.Worksheets（Project Info）。Cells（i，11） .Value 
 .Visible = True 
'.Visible = False 
以
结束Do Until（appIE.READYSTATE = 4而不是appIE.Busy）
 DoEvents'DoEvents释放宏并让excel在等待
时执行其他操作循环
如果是BaseWorkbook.Worksheets（项目信息）。单元格（i，4）.Value = 1然后'无需更新完整项目
 If（InStr（BaseWorkbook.Worksheets（Project Info）。Cells（i，11）.Value，https://www.freelancer.com/contest/ ）<> 0）然后
 BaseWorkbook.Worksheets（项目信息）。单元格（i，4）.Value =竞赛
否则
如果appIE.document.getElementsByClassName（alert-block） ）.Length<> 0然后'项目已删除
 BaseWorkbook.Worksheets（项目信息）。单元格（i，3）.Value = sDate1 
 BaseWorkbook.Worksheets（项目信息）。单元格（i，4 ）.Value = 0 
 BaseWorkbook.Worksheets（Project Info）。Cells（i，6）.Value =Project Deleted
 Else 
 BaseWorkbook.Worksheets（Project Info） .Cells（i，3）.Value = sDate1 
 BaseWorkbook.Worksheets（Project Info）。Cells（i，6）.Value = appIE.document.getElementById（project_status）。innerText 
如果是BaseWorkbook.Worksheets（Project Info）。Cells（i，9）.Value =那么'获取Çountry
 BaseWorkbook.Worksheets（Project Info）。Cells（i，9）.Value = appIE .document.getElementsByClassName（user-flag user-icons）（0）.getElementsByTagName（img）（0）.ge tAttribute（title）
 End if 
如果是BaseWorkbook.Worksheets（Project Info）。Cells（i，10）.Value =那么'获取项目预算
 BaseWorkbook.Worksheets （项目信息）。单元格（i，10）.Value = appIE.document.getElementsByClassName（project-budget）（0）.innerText 
结束如果
如果是BaseWorkbook.Worksheets（Project Info）。Cells（i，1）.Value =然后'获取项目ID 
 BaseWorkbook.Worksheets（Project Info）。Cells（i，1）.Value = appIE.document.getElementsByClassName（ ProjectReport）（0）.getElementsByClassName（normal）（0）.innerText 
结束如果
如果IsObject（appIE.document.getElementById（num-bids））那么'一些私人项目不要没有出价
 BaseWorkbook.Worksheets（Project Info）。Cells（i，8）.Value = appIE.document.getElementById（num-bids）。innerText 
 Else 
 BaseWorkbook.Worksheets（Project Info ）.Cells（i，8）.Value = 0 
结束如果
结束如果
结束如果
结束如果
 BaseWorkbook.Worksheets（仪表板）。单元格（8,6）.Value = i 
下一个i 
 appIE.Quit 
设置appIE = Nothing 
 Application.EnableEvents = True 
 Application.Calculation = xlCalculationAutomatic 
 Application.ScreenUpdating = True 
 Application.DisplayAlerts = True 
 MsgBox（Complete）
 End Sub 

解决方案

我认为如果你使用chrome来通过vba从网上废弃数据，那么从网络中获取数据会更好vba chrome有更多功能，然后是Internet Explorer



链接：重新现实

Hi All. I am trying to scrapping data from website to the excel file.
The route idea here.

For the row from startrow to stoprow.

Navigate ie to the website that the link can get from a cell in excell.
Collect information and save back to excel.
Next

The problem that I only can run about 30 rows each time and then IE crash or IE busy and I have to stop and rerun manually.

Please help.

What I have tried:

Sub UpdateProjectListV2(startRow As Long, StopRow As Long)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim BaseWorkbook As Workbook
    Set BaseWorkbook = ThisWorkbook
    Dim FuncUpdateBid, FuncPStatus, FuncProCountry, FuncProBudget, sDate1 As String
    Dim DeleteP As Object
    Dim NumbidElem As IHTMLElement
    Dim i, iTotalRows As Long
    Dim stemp As String
    iTotalRows = BaseWorkbook.Worksheets("Project Info").Range("B:B").Cells.SpecialCells(xlCellTypeConstants).Count
    sDate1 = Format(Now(), "mmm dd,yyyy")
    Dim appIE As InternetExplorer
    Set appIE = CreateObject("internetexplorer.application")
            For i = startRow To StopRow
                With appIE
                    .navigate BaseWorkbook.Worksheets("Project Info").Cells(i, 11).Value
                    .Visible = True
                    '.Visible = False
                End With
                Do Until (appIE.READYSTATE = 4 And Not appIE.Busy)
                    DoEvents ' DoEvents releases the macro and lets excel do other thing while it waits
                Loop
                If BaseWorkbook.Worksheets("Project Info").Cells(i, 4).Value = 1 Then   'No need to update the complete project
                    If (InStr(BaseWorkbook.Worksheets("Project Info").Cells(i, 11).Value, "https://www.freelancer.com/contest/") <> 0) Then
                        BaseWorkbook.Worksheets("Project Info").Cells(i, 4).Value = "Contest"
                    Else
                        If appIE.document.getElementsByClassName("alert-block").Length <> 0 Then    'Project have been delete
                                    BaseWorkbook.Worksheets("Project Info").Cells(i, 3).Value = sDate1
                                    BaseWorkbook.Worksheets("Project Info").Cells(i, 4).Value = 0
                                    BaseWorkbook.Worksheets("Project Info").Cells(i, 6).Value = "Project Deleted"
                        Else
                                    BaseWorkbook.Worksheets("Project Info").Cells(i, 3).Value = sDate1
                                    BaseWorkbook.Worksheets("Project Info").Cells(i, 6).Value = appIE.document.getElementById("project_status").innerText
                                    If BaseWorkbook.Worksheets("Project Info").Cells(i, 9).Value = "" Then 'Get Çountry
                                        BaseWorkbook.Worksheets("Project Info").Cells(i, 9).Value = appIE.document.getElementsByClassName("user-flag user-icons")(0).getElementsByTagName("img")(0).getAttribute("title")
                                    End If
                                    If BaseWorkbook.Worksheets("Project Info").Cells(i, 10).Value = "" Then   'Get Project budget
                                        BaseWorkbook.Worksheets("Project Info").Cells(i, 10).Value = appIE.document.getElementsByClassName("project-budget")(0).innerText
                                    End If
                                    If BaseWorkbook.Worksheets("Project Info").Cells(i, 1).Value = "" Then  'Get Project ID
                                        BaseWorkbook.Worksheets("Project Info").Cells(i, 1).Value = appIE.document.getElementsByClassName("ProjectReport")(0).getElementsByClassName("normal")(0).innerText
                                    End If
                                        If IsObject(appIE.document.getElementById("num-bids")) Then  'Some private project don't have bid
                                            BaseWorkbook.Worksheets("Project Info").Cells(i, 8).Value = appIE.document.getElementById("num-bids").innerText
                                        Else
                                            BaseWorkbook.Worksheets("Project Info").Cells(i, 8).Value = 0
                                        End If
                        End If
                    End If
                End If
                BaseWorkbook.Worksheets("Dashboard").Cells(8, 6).Value = i
            Next i
    appIE.Quit
    Set appIE = Nothing
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox ("Complete")
End Sub

解决方案

I think if you use chrome to scrap data from the web through vba, it would be an better idea cause to scarp data from web through vba chrome has more features then internet explorer

Link: Re-Reality

这篇关于我的excel VBA报废代码有什么问题。的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！