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

Sub Test()
Dim oRegexp As Object: Set oRegexp = CreateObject("vbscript.regexp")
Dim ar, i, j, s
ar = Sheets("報表").Range("A9:F21").Value 'or .Range("A9").CurrentRegion.Value
With oRegexp
.Pattern = "^[^-]*-"
For i = 1 To UBound(ar)
If .Test(ar(i, 3)) Then ar(i, 3) = .Replace(ar(i, 3), "")
Next
.Pattern = "^[^-]*-[^-]*-"
For i = 1 To UBound(ar)
If .Test(ar(i, 4)) Then ar(i, 4) = .Replace(ar(i, 4), "")
Next
.Pattern = "^(.{2})(.)(.*)[a-zA-Z]$"
For i = 1 To UBound(ar)
If .Test(ar(i, 5)) Then
s = .Replace(ar(i, 5), "$1-$2-$3")
mch = Application.VLookup(s, Sheets("Flow").[A:B], 2, False)
If Not IsError(mch) Then ar(i, 5) = mch
End If
Next
.Pattern = "(SPC|SCL).*$"
'另一種 QVS to SPC/SCL
'.Pattern = "^.*?(QVS.*?(SPC|SCL)).*$"
For i = 1 To UBound(ar)
If .Test(ar(i, 6)) Then ar(i, 6) = .Replace(ar(i, 6), "$1")
Next
End With
Application.ScreenUpdating = False
With Sheets.Add.[A1].Resize(UBound(ar), UBound(ar, 2))
.Value = ar
.Sort key1:=.Cells(1, 1), order1:=xlAscending, key2:=.Cells(1, 4), order2:=xlAscending
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
Application.DisplayAlerts = False
i = 1
For j = 1 To UBound(ar)
If .Cells(j, 2).Value <> .Cells(j + 1, 2).Value Then
If i <> j Then Range(.Cells(i, 1), .Cells(j, 1)).Merge
With .Cells(i, 1).MergeArea.Resize(, .Columns.Count)
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
End With
i = j + 1
End If
Next
Application.DisplayAlerts = True
[B:B].Font.Size = 16
[C:D].Font.Size = 12
ActiveWindow.Zoom = 63
[A:F].EntireColumn.AutoFit
[A:B].HorizontalAlignment = xlCenter
End With
Application.ScreenUpdating = True
End Sub

複製代碼

With oRegexp
.Pattern = "^[^-]*-"
For i = 1 To UBound(ar)
If .Test(ar(i, 3)) Then ar(i, 3) = .Replace(ar(i, 3), "")
Next
.Pattern = "^[^-]*-[^-]*-"

複製代碼

For i = 1 To UBound(ar)
If .Test(ar(i, 4)) Then ar(i, 4) = .Replace(ar(i, 4), "")
Next
.Pattern = "^(.{2})(.)(.*)[a-zA-Z]$"

複製代碼

oRegexp : regular expression 正則表達式/正規表示法，用來查找、替換、提取、驗證字串，
，可參考 http://club.excelhome.net/thread-1128647-1-2.html 學習
.Pattern = "^[^-]*-" 用來設定規則
^ : 字串開頭位置
[^-] : 非-的任意字元
[^-]* : 0~n個非-的任意字元
- : -字元
所以是匹配開頭到第一個-字元
.Test 是用來測試是否符合規則
.Replace 是把符合規則部分的字串取代掉

複製代碼

Sub TEST()
Dim R&, xArea As Range, xR As Range, xH As Range, T, TT, X
R = [報表!A65536].End(xlUp).Row: If R < 9 Then Exit Sub
Set xArea = Sheets("報表").Range("A9:A" & R)
For Each xR In xArea
　　T = xR(1, 3): xR(1, 3) = Mid(T, InStr(T, "-") + 1)
　　xR(1, 4) = Right(xR(1, 4), 9)
　
　　T = xR(1, 5): T = Left(T, 2) & "-" & Mid(T, 3, 1) & "-" & Mid(T, 4, 4)
　　TT = Application.VLookup(T, [Flow!A:B], 2, 0)
　　If Not IsError(TT) Then xR(1, 5) = TT Else xR(1, 5).Font.Color = vbRed
　
　　T = xR(1, 6)
　　T = Mid(T & ",QVS", InStr(T, "QVS") + 4) '取 QVS 以後字串
　　For Each TT In Array("SPC", "SCL")
　　　　X = InStr(T, TT): If X > 0 Then xR(1, 6) = Left(T, X + 2): Exit For
　　Next
Next
　
xArea.Resize(, 6).Sort Key1:=xArea(1, 1), Order1:=xlAscending, _
Key2:=xArea(1, 4), Order2:=xlAscending, Header:=xlNo
　
Application.DisplayAlerts = False
For Each xR In xArea
　　If xR & xR(1, 2) <> xR(0) & xR(0, 2) Then Set xH = xR
　　If xR & xR(1, 2) <> xR(2) & xR(2, 2) Then
　　　Range(xH, xR).Merge: Range(xH(1, 2), xR(1, 2)).Merge
　　　Range(xH, xR(1, 6)).Borders.LineStyle = 1
　　　For i = 7 To 10
　　　　　Range(xH, xR(1, 6)).Borders(i).Weight = xlMedium
　　　Next i
　　End If
Next
End Sub

複製代碼

For h = 9 To 3500
If .Cells(h, "F") = "TBG1" Then
.Cells(h, "AA").Select
Selection.Cut
.Cells(h, "H").Select
ActiveSheet.Paste
End If
next

複製代碼

For h = 9 To 3500
If .Cells(h, "F") = "TBG1" Then
.Cells(h, "AA").Select
Selection.Cut
.Cells(h, "H").Select
ActiveSheet.Paste
End If
If .Cells(h, "F") = "PGH1" Then
.Cells(h, "AA").Select
Selection.Cut
.Cells(h, "I").Select
ActiveSheet.Paste
End If
Next

複製代碼

Dim UType%
Sub 新報表_匯入()
Dim xFile$, x As New Application, xB As Workbook, xS As Worksheet
Dim RepSht As Worksheet, xR As Range, xLab As Range, xAddress$
Set RepSht = Sheets("FMC")
Application.ScreenUpdating = False
RepSht.UsedRange.EntireRow.Delete
Dim currentPKG, currentDevice, whichFirst As String
Dim index As Integer
Dim hasReport As Boolean
title_row = 8
hasReport = False
For i = 1 To Workbooks.Count
With Workbooks(i).Sheets(1)
If .Range("A" & title_row).Value Like "LOTID*" And .Range("D" & title_row).Value Like "TYPE*" And .Range("M" & title_row) Like "QTY*" Then
Set xS = Workbooks(i).Sheets(1)
hasReport = True
i = Workbooks.Count + 1
End If
End With
Next i
If hasReport = False Then MsgBox "找不到報表檔！　": Exit Sub
R = xS.Cells(Rows.Count, 1).End(xlUp).Row + 5
With RepSht
.Range("A1:A" & R) = xS.Range("AJ1:AJ" & R).Value 'pkg
.Range("B1:B" & R) = xS.Range("B1:B" & R).Value 'MO
.Range("C1:C" & R).NumberFormatLocal = "@" 'Date time
.Range("C1:C" & R) = xS.Range("L1:L" & R).Value 'Date time
.Range("D1:D" & R) = xS.Range("A1:A" & R).Value 'LOTID
.Range("E1:E" & R) = xS.Range("D1:D" & R).Value 'DIE TYPE
.Range("F1:F" & R) = xS.Range("P1:P" & R).Value 'STEP
.Range("G1:G" & R) = xS.Range("M1:M" & R).Value ' MO QTY
.Range("AA1:AA" & R) = xS.Range("Q1:Q" & R).Value ' QTY
.Range("H8").Value = "TBG1"
.Range("I8").Value = "PGH1"
.Range("J8").Value = "SLS1"
.Range("K8").Value = "WG"
.Range("L8").Value = "DE01"
.Range("M8").Value = "WM01"
.Range("N8").Value = "FL01"
.Range("O8").Value = "LWS1"
.Range("P8").Value = "WS01"
.Range("Q8").Value = "UTI1"
.Range("R8").Value = "VS01"
.Range("S8").Value = "QVS1"
.Range("T8").Value = "RQVS1"
.Range("U8").Value = "DB"
.Range("V1:W" & R) = xS.Range("E1:F" & R).Value 'CUST DEVICE
.Range("X1:X" & R) = xS.Range("AD1:AD" & R).Value 'Substrate
.Range("Y1:Y" & R) = xS.Range("AE1:AE" & R).Value 'B/D No
.Range("Z1:Z" & R) = xS.Range("AQ1:AQ" & R).Value 'flow
.Range("A8").Value = "PKG"
.Range("A7").Value = ""
.Range("X8").Value = "Substrate"
.Range("X7").Value = ""
.Range("Y8").Value = "B/D No."
.Range("Y7").Value = ""
.Range("D2").Value = ""
.Range("AA8").Value = ""
.Range("A1").Value = "1ST Flow On Hand Report"
.Range("A2").Value = Now()
End With
Dim RRR&, xAArea As Range, xRRR As Range, xHH As Range, Q, TTTT, XXX
RRR = [FMC!A65536].End(xlUp).Row: If RRR < 9 Then Exit Sub
Set xAArea = Sheets("FMC").Range("A9:A" & RRR)
For Each xRRR In xAArea
Q = xRRR(1, 26)
Q = Mid(Q & ",QVS", InStr(Q, "QVS") + 4) '取 QVS 以後字串
For Each TTTT In Array("SPC", "SCL")
XXX = InStr(Q, TTTT): If XXX > 0 Then xRRR(1, 26) = Left(Q, XXX + 2): Exit For
Next
Next
With RepSht
' For g = 3500 To 8 Step -1
' If .Cells(g, "V") Like "*CSP*" Or .Cells(g, "V") Like "*L1*" Or .Cells(g, "V") Like "*L2*" _
' Or .Cells(g, "V") Like "*ENG*" Or .Cells(g, "A") Like "LQFP*" Or .Cells(g, "A") Like "PLCC*" _
' Or .Cells(g, "A") Like "SOP*" Or .Cells(g, "A") Like "SSOP*" Or .Cells(g, "A") Like "TSOP*" _
' Or .Cells(g, "A") Like "TSSOP*" Or .Cells(g, "A") Like "TFBGA*" Then
' .Rows(g).Delete
' End If
' Next
RepSht.Select
For h = 9 To 3500
.Cells(h, "AA").Select
Selection.Cut
Select Case .Cells(h, "F").Value
Case "TBG1"
.Cells(h, "H").Select
ActiveSheet.Paste
Case "PGH1"
.Cells(h, "I").Select
ActiveSheet.Paste
Case "SLS1"
.Cells(h, "J").Select
ActiveSheet.Paste
Case "DE01"
.Cells(h, "L").Select
ActiveSheet.Paste
Case "WM01"
.Cells(h, "L").Select
ActiveSheet.Paste
Case "FL01"
.Cells(h, "N").Select
ActiveSheet.Paste
Case "LWS1"
.Cells(h, "O").Select
ActiveSheet.Paste
Case "WS01"
.Cells(h, "P").Select
ActiveSheet.Paste
Case "UTI1"
.Cells(h, "Q").Select
ActiveSheet.Paste
Case "VS01"
.Cells(h, "R").Select
ActiveSheet.Paste
Case "QVS1"
.Cells(h, "S").Select
ActiveSheet.Paste
Case "RQVS1"
.Cells(h, "T").Select
ActiveSheet.Paste
Case "DB"
.Cells(h, "U").Select
ActiveSheet.Paste
End Select
Next
For e = 9 To 3500
If .Cells(e, "F") Like "WG*" Then
.Cells(e, "AA").Select
Selection.Cut
.Cells(e, "K").Select
ActiveSheet.Paste
End If
Next
End With
'xB.Close 0
Dim RR&, xArea As Range, xRR As Range, xH As Range, T, TT, XX
RR = [FMC!A65536].End(xlUp).Row: If RR < 9 Then Exit Sub
Set xArea = Sheets("FMC").Range("A9:A" & R)
For Each xRR In xArea
T = xRR(1, 25): xRR(1, 25) = Mid(T, InStr(T, "-") + 1)
xRR(1, 24) = Right(xRR(1, 24), 9)
T = xRR(1, 5): T = Left(T, 2) & "-" & Mid(T, 24, 1) & "-" & Mid(T, 23, 4)
Next
xArea.Resize(, 26).Sort Key1:=xArea(1, 1), Order1:=xlAscending, _
Key2:=xArea(1, 25), Order2:=xlAscending, Header:=xlNo
Application.DisplayAlerts = False
For Each xRR In xArea
If xRR & xRR(1, 2) <> xRR(0) & xRR(0, 2) Then Set xH = xRR
If xRR & xRR(1, 2) <> xRR(2) & xRR(2, 2) Then
Range(xH, xRR).Merge: Range(xH(1, 2), xRR(1, 2)).Merge
Range(xH, xRR).Merge: Range(xH(1, 3), xRR(1, 3)).Merge
Range(xH, xRR).Merge: Range(xH(1, 7), xRR(1, 7)).Merge
Range(xH, xRR).Merge: Range(xH(1, 22), xRR(1, 22)).Merge
Range(xH, xRR).Merge: Range(xH(1, 23), xRR(1, 23)).Merge
Range(xH, xRR).Merge: Range(xH(1, 24), xRR(1, 24)).Merge
Range(xH, xRR).Merge: Range(xH(1, 25), xRR(1, 25)).Merge
Range(xH, xRR).Merge: Range(xH(1, 26), xRR(1, 26)).Merge
Range(xH, xRR(1, 26)).Borders.LineStyle = 1
For i = 7 To 10
Range(xH, xRR(1, 26)).Borders(i).Weight = xlMedium
Next i
End If
Next
With RepSht
Sheets("FMC").Select
Cells.Select
Selection.Font.Size = 14
With Selection.Font
.Name = "Arial"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Range("A8:Z8").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
End With
Range("A8").Select
ActiveWindow.Zoom = 63
Call 調整
End Sub
Sub 報表_清除()
Sheets("FMC").UsedRange.EntireRow.Delete
End Sub
Sub 調整()
Dim RepSht As Worksheet
Set RepSht = Sheets("FMC")
With RepSht
Columns("A:A").Select
Selection.ColumnWidth = 30
Columns("B:B").Select
Selection.ColumnWidth = 11.63
Columns("C:C").Select
Selection.ColumnWidth = 16
Columns("D:D").Select
Selection.ColumnWidth = 20.88
Columns("E:E").Select
Selection.ColumnWidth = 8.25
Columns("F:F").Select
Selection.ColumnWidth = 9.25
Columns("G:G").Select
Selection.ColumnWidth = 10
Selection.NumberFormatLocal = "#,##0_ "
Columns("H:U").Select
Selection.ColumnWidth = 8.63
Columns("V:V").Select
Selection.ColumnWidth = 40.38
ActiveWindow.SmallScroll ToRight:=11
Columns("W:W").Select
Selection.ColumnWidth = 59.75
Columns("X:X").Select
Selection.ColumnWidth = 15.5
Columns("Y:Y").Select
Selection.ColumnWidth = 10.5
ActiveWindow.SmallScroll ToRight:=4
Columns("Z:Z").Select
Selection.ColumnWidth = 93.38
Range("A7").Select
End With
End Sub

複製代碼