[VBA ] 請問一下 這個該怎樣修改 才會正常執行
這是一個抓奇摩評價的VBA
是一個高手Jackylu寫的
可是我怎跑 第十七行就是說有問題
可以請各位高手協助一下嗎?
原始來源來自http://vba.blogspot.com/
如何把yahoo奇摩拍賣的評價匯入EXCEL,使用巨集或VBA
* 以下VBA執行前,請將UserID填入自己的Yahoo拍賣ID喔,並請登入yahoo拍賣.
* 將以下VBA原封不動copy的module1下即可.
* 沒有寫的很完整,想要防呆或增加功能,就自己試試囉~
* 若要捉別人的,程式只要做小修改即可......
Private Declare Function URLDownloadToFile Lib "urlmon" Alias
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub GetYahooEva()
UserID = "xxxxxx" '請填入自己的帳號
HtmlFile = "C:\JackyLu.txt"
TargetUser = "http://tw.user.bid.yahoo.com/tw/show/rating?userID=" & UserID
DownloadFile CStr(TargetUser), CStr(HtmlFile)
AllData = UTF8ToBig5(HtmlFile)
TargetDataStart = "共 "
TargetDataStartLen = Len(TargetDataStart)
TargetDataStartPosition = InStr(AllData, TargetDataStart)
TargetDataStop = "<"
TargetDataStopLen = Len(TargetDataStop)
TargetDataStopPosition = InStr(TargetDataStartPosition + TargetDataStartLen,
AllData, TargetDataStop)
SheetCnt = Mid(AllData, TargetDataStartPosition + TargetDataStartLen,
TargetDataStopPosition - TargetDataStartPosition - TargetDataStartLen)
Workbooks.Add
Sheet1.Name = Format(Date, "yyyymmdd") & Format(Time, "hhmmss")
For SHN = 1 To SheetCnt
TargetUser = "http://tw.user.bid.yahoo.com/tw/show/rating?userID=" & UserID &
"&pageNo=" & SHN
DownloadFile CStr(TargetUser), CStr(HtmlFile)
AllData = UTF8ToBig5(HtmlFile)
AllData = ReplaceUnnecessary(AllData)
AllData = TrimAllBlank(AllData)
Do
TargetDataStart = "評價為："
TargetDataStartLen = Len(TargetDataStart)
TargetDataStartPosition = InStr(AllData, TargetDataStart)
TargetDataStop = "[回應]"
TargetDataStopLen = Len(TargetDataStop)
TargetDataStopPosition = InStr(TargetDataStartPosition + TargetDataStartLen,
AllData, TargetDataStop)
If TargetDataStartPosition <> 0 Then
T = Mid(AllData, TargetDataStartPosition, TargetDataStopPosition -
TargetDataStartPosition)
NL1 = "買家滿意度"
NL2 = "意見︰"
NL3 = "回覆︰"
T = Replace(T, NL1, Chr(10) & NL1)
T = Replace(T, NL2, Chr(10) & NL2)
T = Replace(T, NL3, Chr(10) & NL3)
x = x + 1
Cells(x, 1).FormulaR1C1 = T
AllData = Mid(AllData, TargetDataStopPosition)
Else
Exit Do
End If
Loop
Next
Columns("A:A").ColumnWidth = 200
Cells.EntireRow.AutoFit
ActiveWindow.Zoom = 75
End Sub
Function UTF8ToBig5(HtmlFile)
Dim objStream As Object
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 2
.Mode = 3
.Open
.Charset = "Big5" 'utf-8 Big5 或其他編碼
.LoadFromFile HtmlFile
UTF8ToBig5 = .ReadText
.Close
End With
End Function
Function TrimAllBlank(TrimB)
TrimB = Replace(TrimB, " ", "")
If InStr(TrimB, " ") > 0 Then
TrimB = TrimAllBlank(TrimB)
End If
TrimAllBlank = TrimB
End Function
Function ReplaceUnnecessary(RUString)
RUString = Replace(RUString, Chr(9), "")
RUString = Replace(RUString, Chr(13), "")
RUString = Replace(RUString, Chr(10), "")
RUString = Replace(RUString, " ", "")
Do
LI = InStr(RUString, "<") If LI = 0 Then Exit Do RI = InStr(LI, RUString, ">")
RUString = Replace(RUString, Mid(RUString, LI, RI - LI + 1), "")
Loop
ReplaceUnnecessary = RUString
End Function
Public Function DownloadFile(URL As String, LocalFilename As String) As
Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 218.162.96.135
推
03/05 17:24, , 1F
03/05 17:24, 1F
→
03/05 17:25, , 2F
03/05 17:25, 2F
→
03/05 20:17, , 3F
03/05 20:17, 3F