- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
3#
發表於 2014-12-18 12:25
| 只看該作者
本帖最後由 GBKEE 於 2014-12-22 16:51 編輯
回復 2# happycoccolin
試試看- Option Explicit
- Sub Ex()
- Dim AR, Sh As Worksheet
- Dim i As Long, Msg As Variant, W As Single, M As Single, s As String, filein As String, fileout As String
- filein = Application.GetOpenFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="請選擇要比對的檔案")
- If Not TypeName(filein) = "String" Then Exit Sub '取消則結束
- With Workbooks.Open(filein)
- Set Sh = .Sheets(1)
- AR = Sh.UsedRange.Columns("S")
- End With
- AR(1, 1) = "PASS/FAIL"
- For i = 2 To UBound(AR)
- Msg = ""
- Select Case Cells(i, "O")
-
- Case ""
- '**********************************************************************
- '2.若是O欄(Implementation)為空,請在S欄位(結果欄位)顯示"無工作電壓/電流"
- Msg = "無工作電壓/電流"
- Case "C"
- 'IF(O1="C",IF(『擷取M1欄"/"後字元』*0.6>Q1,PASS,FAIL))
- Msg = Val(Split(Cells(i, "M"), "/")(1)) * 0.6 > Cells(i, "Q")
- Case "R"
- Msg = Split(Cells(i, "P"), "_") 'Msg = P欄中用 "_" 字串分割傳回的陣列
- If UBound(Msg) = 0 Then '陣列元素只有一個,P欄中沒有"_"的字元
- Msg = Split(Cells(i, "P"), "_")(0)
- ElseIf UBound(Msg) > 0 Then 'P欄中有"_"的字元
- Msg = Split(Cells(i, "P"), "_")(1)
- If Mid(UCase(Msg), 1, 1) = "H" Then
- '"r0603_hxx"(xx是變數) : r+後四碼字串_hxx
- Msg = Split(Cells(i, "P"), "_")(0)
- End If
- End If
- W = 0
- Select Case Right(Trim(Msg), 4) ' P欄後4碼字串
- Case "0402" '零件大小
- W = 0.0625 '功率(W)
- Case "0603"
- W = 0.1
- Case "0805"
- W = 0.125
- Case "1206"
- W = 0.25
- Case "1210"
- W = 0.3333
- Case "1812"
- W = 0.5
- Case "2010"
- W = 0.75
- Case "2512"
- W = 1
- End Select
- '**********************************************************************
- '4.以下這段,若是Kohm & Mohm中間帶一個空格(K ohm & M ohm),一樣可以判斷出來嗎?
- '**************************************************************************
- Msg = UCase(Right(Trim(Cells(i, "M")), 5))
-
- If Msg = "K OHM" Or Msg = "M OHM" Then '讀取5個字元,取得歐姆單位
- 'M1需判斷值:以歐姆值計算.若為Kohm：其值×1000、若為Mohm：其值×1000000)
- '例如:M1=2.64Kohm=2.64*1000=2640
- M = Val(Cells(i, "M")) * 10000 'Kohm
- If Msg = "M OHM" Then M = Val(Cells(i, "M")) * 1000000
- 'IF(O1="R",IF(OR((M1<>"0ohm"),(M1<>"0 ohm")),IF(Q1平方/2640-2640*N1<0.0625*0.6,PASS,FAIL)))
- Msg = Cells(i, "Q") ^ 2 / M - M * Cells(i, "N") < W * 0.6
- End If
-
- If Not IsNumeric(Msg) Then '5個字元,非歐姆單位
- Msg = UCase(Right(Trim(Cells(i, "M")), 4)) '讀取4個字元,取得歐姆單位
- If Msg = "0OHM" Or Msg = " OHM" Then '『非0 ohm』：ohm類的字元前面可能帶空格,部分未帶空格
- 'IF(O1="R",IF(OR((M1="0ohm"),(M1="0 ohm")),IF(Q1平方*N1< W參閱項目2*0.6,PASS,FAIL)))
- M = Val(Cells(i, "M"))
- Msg = Cells(i, "Q") ^ 2 * Cells(i, "N") < W * 0.6
- ElseIf Msg = "KOHM" Or Msg = "MOHM" Then
- 'M1需判斷值:以歐姆值計算.若為Kohm：其值×1000、若為Mohm：其值×1000000)
- '例如:M1=2.64Kohm=2.64*1000=2640
- M = Val(Cells(i, "M")) * 10000 'Kohm
- If Msg = "MOHM" Then M = Val(Cells(i, "M")) * 1000000
- 'IF(O1="R",IF(OR((M1<>"0ohm"),(M1<>"0 ohm")),IF(Q1平方/2640-2640*N1<0.0625*0.6,PASS,FAIL)))
- Msg = Cells(i, "Q") ^ 2 / M - M * Cells(i, "N") < W * 0.6
- End If
- End If
- If Not IsNumeric(Msg) Then '4個字元,非歐姆單位
- Msg = UCase(Right(Trim(Cells(i, "M")), 3)) '剩下3個字元,最小的歐姆單位
- M = Val(Cells(i, "M"))
- Msg = Cells(i, "Q") ^ 2 * Cells(i, "N") < W * 0.6
-
- End If
- Case "BEAD"
- 'IF(O1="Bead",IF(Q1平方<『判斷F1欄”/”後字元,若出現mA字元,其值要÷1000反之則否』平方*0.6,PASS,FAIL)))
- '例如:F1值=FERRITE BEAD(0402)600OHM/300mA,則執行”/”後字元=300mA=300/1000
- 'IF(O1="Bead",IF(Q1平方<0.3平方*0.6,PASS,FAIL)))
- If InStr(Cells(i, "f"), "/") Then '判斷F1欄 有”/”此字元
- M = Val(Split(Cells(i, "f"), "/")(1))
- Msg = InStr(UCase(Split(Cells(i, "f"), "/")(1)), "MA")
- If Msg Then M = Val(Split(Cells(i, "f"), "/")(1)) / 1000
- Msg = Cells(i, "Q") ^ 2 > M
- End If
- End Select
- If Msg <> "" Then
- If Msg = "無工作電壓/電流" Then
- AR(i, 1) = Msg
- Else
- AR(i, 1) = IIf(Msg, "PASS", "FAIL")
- End If
- End If
- Next
-
- With Sh.UsedRange.Columns("S")
- .Cells = AR
- Msg = Array("PASS", "FAIL")
- For i = 0 To UBound(Msg)
- .Replace Msg(i), "=EX", xlWhole
- With .SpecialCells(xlCellTypeFormulas, xlErrors)
- .Cells = Msg(i)
- 'PASS顯示綠底黑字 FAIL顯示紅底白字
- .Font.Color = IIf(i = 0, vbBlack, vbWhite)
- .Interior.Color = IIf(i = 0, vbGreen, vbRed)
- End With
-
- Next
- .SpecialCells(xlCellTypeConstants).EntireRow.Copy
- End With
- '**********************************************************
- '1.我目前是想做成我可以執行此程式後跳出一個視窗->讓我挑選要載入的檔案->載入後執行運算->跳出視窗讓我可另存新檔~
- If MsgBox("請問是否要儲存檔案?", vbYesNo) = vbYes Then
- fileout = Application.GetSaveAsFilename(FileFilter:="Excel 活頁簿 (*.xlsx),*.xlsx", Title:="另存為新檔")
- If Not TypeName(fileout) = "String" Then Exit Sub '取消則結束
- With Workbooks.Add(1)
- .Sheets(1).Paste
- .SaveAs fileout ', FileFormat:=xlWorkbookDefault
- .Close True
- End With
- Else
- Application.CutCopyMode = False
-
- End If
- '******************************
- '1不要將結果顯示在原檔案
- Sh.Parent.Close False
-
- End Sub
|
|
發表於 2014-12-16 11:54
| 
