如何把yahoo奇摩拍賣的評價匯入EXCEL,使用巨集或VBA

如何把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