這個宏命令是自動抓取一個網站的資料
http://www27392u.sakura.ne.jp/index_news.cgi
下的2014秋板塊下的資料
抓取的資料有
希望大神幫我看看vba撰寫的內容哪里有錯誤
uj5u.com熱心網友回復：
因為不能上傳附件所以我就把代碼復制下來
希望大神幫我看看
uj5u.com熱心網友回復：
中間加黃的那一段是選擇除錯后出現的Sub Replace_Old()
Application.ScreenUpdating = False
'Delete If Exist
If Worksheets(7).Name = Month(Date) & "." & Day(Date) Then
Application.DisplayAlerts = False
Sheets(7).Delete
Application.DisplayAlerts = True
End If
' Copy Old Table
Sheets(7).Range("A4:M100").Copy
' Paste Old Table
Sheets("OLD").Range("A4").PasteSpecial
End Sub
Sub Update_New()
Application.ScreenUpdating = False
' Sort Records
With Worksheets("NEW").AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("D2:D13"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With Worksheets("NEW").AutoFilter.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A13"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' Clear Border Colors & thickness and Background Color
Dim NewForm As Range
Set NewForm = Range(Worksheets("NEW").Range("A4:M4"), Worksheets("NEW").Range("A4:M4").End(xlDown))
With NewForm
.Borders(xlInsideVertical).ColorIndex = 0
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).ColorIndex = 0
.Borders(xlInsideHorizontal).Weight = xlThin
.Interior.Pattern = xlNone
.Interior.TintAndShade = 0
.Interior.PatternTintAndShade = 0
End With
' Draw Lines
Dim i As Integer
i = 4
Do While i < 61
If Worksheets("OLD").Cells(i, "N").Value = 6 Then '82515
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Color = RGB(165, 42, 42)
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Weight = xlThick
ElseIf Worksheets("OLD").Cells(i, "N").Value = 5 Then '33813
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Color = RGB(255, 215, 0)
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Weight = xlThick
ElseIf Worksheets("OLD").Cells(i, "N").Value = 4 Then '10000
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Weight = xlThick
ElseIf Worksheets("OLD").Cells(i, "N").Value = 3 Then '5000
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Color = RGB(255, 255, 0)
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Weight = xlThick
ElseIf Worksheets("OLD").Cells(i, "N").Value = 2 Then '2899
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Color = RGB(50, 205, 50)
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Weight = xlThick
ElseIf Worksheets("OLD").Cells(i, "N").Value = 1 Then '883
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Color = RGB(0, 0, 255)
Worksheets("NEW").Range("A4:M4").Offset(i - 4, 0).Borders(xlEdgeBottom).Weight = xlThick
End If
i = i + 1
Loop
End Sub
Sub Copy_New()
'Create Sheet
Worksheets.Add after:=Worksheets(6)
'Copy New
Worksheets(1).Cells.Copy
'Paste to New Sheet
Application.DisplayAlerts = False
With Worksheets(7)
.Name = Month(Date) & "." & Day(Date)
.Paste
.Cells.Copy
.Range("A1").PasteSpecial Paste:=xlPasteValues
.Visible = False
End With
Application.DisplayAlerts = True
End Sub
Sub ObtainData()
Application.ScreenUpdating = False
'Cumulative PT Now
'Clear Target Cells
Sheets("CU").Range("$A$1:$G$3500").AutoFilter
Sheets("Main").Range("$A$1:$G$3500").AutoFilter
Sheets("Main").Range("A2:A10000").Clear
Application.StatusBar = "Loading Cumulative PT from Sakura."
'to refer to the running copy of Internet Explorer
Dim ie As InternetExplorer
'to refer to the HTML document returned
Dim html As HTMLDocument
'open Internet Explorer in memory, and go to website
Set ie = New InternetExplorer
ie.Visible = False
ie.navigate "http://www27392u.sakura.ne.jp/index_news.cgi"
'Wait until IE is done loading page
'Do While (ie.Busy Or ie.readyState <> READYSTATE_COMPLETE)
' DoEvents
'Loop
Application.Wait Now + TimeValue("00:00:05")
'show text of HTML document returned
Set html = ie.document
'Paste Source Code
Dim arr
arr = Split(html.DocumentElement.outerHTML, vbLf) 'or vbCR or vbCrLf
Sheets("Main").Range("A2").Resize(UBound(arr) + 1, 1).Value = Application.Transpose(arr)
' Copy Records to Sheet NEW
Sheets("Main").Range("$A$1:$G$3500").AutoFilter
Sheets("Main").Range("$A$1:$G$3500").AutoFilter Field:=7, Criteria1:="<>"
If InStr(1, Sheets("Main").Range("G1").End(xlDown).Value, "2014", 1) = 0 Then
MsgBox ("Data is preparing in Sakura. Please wait a minute and try again.")
Else
' Clear Records
Sheets("CU").Range("A2:F500").Clear
Sheets("form").Range("A1").AutoFilter
Sheets("form").Range("A2:D500").Clear
' Copy Records to Sheet CU
Sheets("Main").Range("$A$1:$G$3500").AutoFilter
Sheets("Main").Range("$A$1:$G$3500").AutoFilter Field:=3, Criteria1:="<>"
'Name
Range(Sheets("Main").Range("C1"), Sheets("Main").Range("C1").End(xlDown)).Copy
Sheets("CU").Range("F1").PasteSpecial Paste:=xlPasteValues
'Sales Date
Range(Sheets("Main").Range("D1"), Sheets("Main").Range("D1").End(xlDown)).Copy
Sheets("CU").Range("E1").PasteSpecial Paste:=xlPasteValues
'Cumulative PT
Range(Sheets("Main").Range("E1"), Sheets("Main").Range("E1").End(xlDown)).Copy
Sheets("CU").Range("C1").PasteSpecial Paste:=xlPasteValues
'Hyperlink
Range(Sheets("Main").Range("F1"), Sheets("Main").Range("F1").End(xlDown)).Copy
Sheets("form").Range("A1").PasteSpecial Paste:=xlPasteValues
' Copy Renewal Date to Sheet NEW
Sheets("Main").Range("$A$1:$G$3500").AutoFilter
Sheets("Main").Range("$A$1:$G$3500").AutoFilter Field:=7, Criteria1:="<>"
Sheets("Main").Range("G1").End(xlDown).Copy
Sheets("NEW").Range("A4").End(xlDown).End(xlDown).PasteSpecial Paste:=xlPasteValues
Sheets("NEW").Range("A4").End(xlDown).End(xlDown).Font.Bold = True
'Predicted PT Now
'Clear Target
Sheets("PRE2").Range("A:D").AutoFilter
Sheets("PRE2").Range("A2:A500").Clear
Sheets("PRE2").Range("D2:D500").Clear
Dim i As Integer
Dim NoOfRows As Integer
Dim weblink As String
Dim BDDVDName As String
Dim CompleteFlag As Boolean
i = 1
NoOfRows = Sheets("Form").UsedRange.Rows.Count
CompleteFlag = Sheets("NAME").Range("J2").Value
Application.StatusBar = "Predicted PT: 0/" & NoOfRows - 1 & " Completed"
uj5u.com熱心網友回復：
Do While i < NoOfRows'Access WebPage
weblink = Sheets("Form").Range("A1").Offset(i, 0).Value
ie.navigate weblink
'If CompleteFlag Then
' 'Wait until IE is done loading page
' Do While (ie.Busy Or ie.readyState <> READYSTATE_COMPLETE)
' DoEvents
' Loop
' Else
Application.Wait Now + TimeValue("00:00:03")
'End If
'show text of HTML document returned
Set html = ie.document
'Paste Source Code
Sheets("work").Range("$A$1:$C$3500").AutoFilter
arr = Split(html.DocumentElement.outerHTML, vbLf) 'or vbCR or vbCrLf
Sheets("work").Range("A2").Resize(UBound(arr) + 1, 1).Value = Application.Transpose(arr)
'Find BD Name
Sheets("work").Range("$A$1:$G$3500").AutoFilter Field:=2, Criteria1:="<>"
BDDVDName = Sheets("work").Range("B1").End(xlDown).Value
Sheets("work").Range("B1").End(xlDown).Copy
'Paste BD Name
Sheets("PRE2").Range("A1").Offset(i, 0).PasteSpecial Paste:=xlPasteValues
'Find Predicted PT
Sheets("work").Range("$A$1:$G$3500").AutoFilter
Sheets("work").Range("$A$1:$G$3500").AutoFilter Field:=3, Criteria1:="<>"
Sheets("work").Range("C1").End(xlDown).Copy
'Paste Predicted PT
Sheets("PRE2").Range("D1").Offset(i, 0).PasteSpecial Paste:=xlPasteValues
If BDDVDName <> Sheets("PRE2").Range("A1").Offset(i - 1, 0).Value Then
Application.StatusBar = "Predicted PT: " & i & "/" & NoOfRows - 1 & " Completed"
i = i + 1
End If
Loop
Call CreateForm
End If
Application.StatusBar = False
'close down IE
ie.Quit
Set ie = Nothing
End Sub
Sub CreateForm()
If Sheets("Old").Range("S9") > 0 Then
MsgBox ("New BD/DVD name(s) in Cumulative PT is/are found. Please verify.")
Do While Sheets("Old").Range("S9") > 0
'Copy BDDVD Name
With Sheets("CU")
.Range("A:O").AutoFilter
.Range("A:O").AutoFilter Field:=15, Criteria1:="#N/A"
End With
'Paste BDDVD Name
Sheets("NAME").Range("D1").End(xlDown).Offset(1, 0).Value = Replace(Sheets("CU").Range("F1").End(xlDown).Value, "~", "")
Sheets("work").Range("F1").Value = Sheets("CU").Range("F1").End(xlDown).Value
Load UserForm1
UserForm1.Show
Loop
End If
If Sheets("Old").Range("S11") > 0 Then
MsgBox ("New BD/DVD name(s) in Predicted PT is/are found. Please verify.")
Load UserForm1
Do While Sheets("Old").Range("S11") > 0
'Copy BDDVD Name
With Sheets("PRE2")
.Range("A:D").AutoFilter
.Range("A:D").AutoFilter Field:=3, Criteria1:="#N/A"
End With
'Paste BDDVD Name
Sheets("NAME").Range("D1").End(xlDown).Offset(1, 0).Value = Replace(Sheets("PRE2").Range("A1").End(xlDown).Value, "~", "")
Sheets("work").Range("F1").Value = Sheets("PRE2").Range("A1").End(xlDown).Value
Load UserForm1
UserForm1.Show
Loop
End If
Do While Sheets("Old").Range("S13") > 0
'Copy BDDVD Name
With Sheets("NAME")
.Range("D:G").AutoFilter
.Range("D:G").AutoFilter Field:=4, Criteria1:=1
End With
'Paste BDDVD Name
Dim selectrange As Range
Set selectrange = Sheets("NEW").Range("A4").End(xlDown)
With selectrange
.Offset(1, 4).Value = Sheets("NAME").Range("E1").End(xlDown).Value
.Resize(1, 4).Copy
.Offset(1, 0).Resize(1, 4).PasteSpecial
.Offset(0, 4).Resize(1, 2).Copy
.Offset(1, 4).Resize(1, 2).PasteSpecial Paste:=xlPasteFormats
.Offset(0, 6).Resize(1, 7).Copy
.Offset(1, 6).Resize(1, 7).PasteSpecial
End With
selectrange.Offset(2, 0).Resize(2, 1).Cut
selectrange.Offset(3, 0).Select
ActiveSheet.Paste
Loop
Call Replace_Old
Call Update_New
Call Copy_New
Sheets(1).Select
MsgBox ("Data is obtained Successfully.")
End Sub
Sub PrintOut()
Dim printername As String
printernane = Sheets("NAME").Range("J1").Value
Sheets(1).PrintOut ActivePrinter:=printernane
End Sub
Sub test()
'to refer to the running copy of Internet Explorer
Dim ie As InternetExplorer
'to refer to the HTML document returned
Dim html As HTMLDocument
'open Internet Explorer in memory, and go to website
Set ie = New InternetExplorer
ie.Visible = False
ie.navigate "http://www27392u.sakura.ne.jp/show.cgi?n=B00MWVOFJ2"""
'Wait until IE is done loading page
Do While (ie.readyState <> READYSTATE_COMPLETE)
'Do While (ie.Busy Or ie.readyState <> READYSTATE_COMPLETE)
'Do While (ie.Busy Or ie.readyState <> READYSTATE_COMPLETE)
DoEvents
Loop
ie.Quit
Set ie = Nothing
End Sub
uj5u.com熱心網友回復：
最好有實體，Excel2003和2007（及以后）版本還是有一些區別的，先確定2臺電腦的excel版本是否一致，然后逐行除錯吧。uj5u.com熱心網友回復：
看不清黃字內容，應該是錯誤斷點處轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/108093.html
標籤：VBA