麻辣家族討論版版 - Powered by Discuz! Board

Option Explicit
Sub Ex1()
On Error GoTo AR
Dim A, B, C, D, E, F, G, H, I, J, K As String, R, rng As Range
Dim URL, URL1, URL2, URL3, URL4, URL5, URL6, URL7, URL8, URL9, URL10 As String
J = InputBox("請輸入網頁號碼")
H = InputBox("請輸入工單號碼")
With Sheets(2)
Set rng = .Range("A1", .Range("A65535").End(xlUp))
End With
'URL1 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\NXTL_Feeder SetupRepIndex_T.html"
'URL2 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\NXTL_Part PlacementRepIndex_T.html"
'URL3 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\XPF_Feeder SetupRepIndex_T.html"
'URL4 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\XPF_Part PlacementRepIndex_T.html"
'URL5 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\NXTL_Feeder SetupRepIndex_B.html"
'URL6 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\NXTL_Part PlacementRepIndex_B.html"
'URL7 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\XPF_Feeder SetupRepIndex_B.html"
'URL8 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\XPF_Part PlacementRepIndex_B.html"
'URL9 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\XPFB_Feeder SetupRepIndex_B.html"
'URL10 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & "\XPFB_Part PlacementRepIndex_B.html"
With CreateObject("InternetExplorer.Application")
For Each URL In rng
URL1 = "C:\FujiFlexa\Client\Report\Jobdata\job00" & J & URL
.Visible = False
' On Error Resume Next
On Error GoTo AR
' On Error Resume Next '找不到網頁還無法解決
' On Error GoTo 0
.Navigate URL1
Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
.execwb 17, 2 '選取網頁內容
.execwb 12, 2 '複製網頁內容
Sheets(1).Activate
With ActiveSheet '指定工作表
.Cells.Clear '清理工作表
.[a1].Select
.PasteSpecial Format:="Unicode 文字", Link:=False, DisplayAsIcon:= _
False, NoHTMLFormatting:=True
.[a1].Select
End With
.Quit
If InStr([A2], "Feeder") Then
A = "_" + Mid([A7], 9, 3) + "A" + Right([A9], 2) 'NXTA_T
' MsgBox A
B = Left([A9], Len([A9]) - 2) '去掉尾巴的_T
If InStr(Mid(B, 13, 3), "_") Then
C = Mid(B, 13, 3) '如果有_就是LA或LB
Else
C = Mid(B, 13, 4) '如果沒有就是LAB或LBB
End If
If InStr(Mid([A9], 23, 1), "_") Then
D = Right(B, Len(B) - 22) '抓程式版本
Else
D = Right(B, Len(B) - 21) '抓程式版本
End If
I = "_" + Mid([A11], 10, 6)
Else
A = "_" + Mid([A7], 9, 3) + "A" + Right([A8], 2) + "S" 'NXTA_TS
' MsgBox A
B = Left([A8], Len([A8]) - 2) '去掉尾巴的_T
If InStr(Mid(B, 13, 3), "_") Then
C = Mid(B, 13, 3) '如果有_就是LA或LB
Else
C = Mid(B, 13, 4) '如果沒有就是LAB或LBB
End If
If InStr(Mid([A8], 23, 1), "_") Then
D = Right(B, Len(B) - 22) '抓程式版本
Else
D = Right(B, Len(B) - 21) '抓程式版本
End If
I = "_" + Mid([A10], 10, 6)
End If
' MsgBox B
' MsgBox C
' MsgBox D
E = C + H + D + I + A
MsgBox E
AR:
Next
End With
End Sub

複製代碼

Option Explicit
Sub Ex1()
Dim IE As Object
Dim Rng As Range, UrL As String, R As Range, j
Set IE = CreateObject("InternetExplorer.Application")
With Sheets(2)
Set Rng = .Range("A1", .Range("A65535").End(xlUp))
End With
For Each R In Rng
UrL = "C:\FujiFlexa\Client\Report\Jobdata\job00" & j & R
If Dir(UrL) = "" Then '檢查不到檔案
If MsgBox("找不到 " & UrL & vbLf & "是(Y):繼續下一個網頁" & vbLf & "否(N):結束程式", vbYesNo) = vbYes Then
GoTo AG1
Else
IE.Quit
Exit Sub
End If
End If
With IE
.Navigate UrL
Do While .Busy Or .readyState <> 4: DoEvents: Loop
'**************
'程式碼********
'**************
End With
AG1:
Next
IE.Quit
End Sub

複製代碼