伊莉討論區

標題: 相對欄位迴圈判斷問題 [打印本頁]
作者: v03586    時間: 2016-1-20 02:02 AM     標題: 相對欄位迴圈判斷問題

本帖最後由 v03586 於 2016-1-20 02:04 AM 編輯

請問一下我有一個跑報表程式...遇到一個問題

Q1.我針對程式碼修改至我自己的程式報表(FMC), 發現欄位Substrate 與 B/D No 欄位 就是取 『-』 好像切得不是很乾淨 , 不知道是不是程式判斷有錯誤 (X與Y欄位) , 此欄位在ONHAND2HR_Ist_Flow 中是在<AD/AE欄位>
還有最後一欄一長串那個(Flow)<Z欄位>, 只要保留前面到字串中『  SPC  』 或 『  SCL  』,後面都不要
跑巨集的時候能呈獻 『  QVS 』後就往下自動換列嗎,
範例:
WGD,FL0,WS0,UTI,VS0,QVS,
STB,PL0,DA0,SA0,EC0,DA1,RA2,EC1,PLM,WB0,PI0,QPI,RA3,CA0,EC2,SPC
[attach]112667280[/attach]
Q2.還有可以將匯入報表模式改成 Excel 打開後比對 (參考報表資料來源:ONHAND2HR_Ist_Flow)
          A2欄位有 ON HAND--PC_ONHAND2HR_1ST_FLOW 就等同匯入報表嗎?  
      意思就是只要打開程式EXCEL 與 參考資料來源EXCEL<ONHAND2HR_Ist_Flow> 比對資料表Sheet1 A2欄有ON HAND--PC_ONHAND2HR_1ST_FLOW 字眼  就能執行程式目前是必須將檔案下載 , 與程式放在同一個資料夾, 才能執行程式

Q3.欄位線的劃置能全部細線條 , 依照B/D No 不同畫粗線條嗎? (執行結果excel那樣)
   目前好像不同的MO 畫粗線

請問大大能否新增幾樣功能嗎
1. 功能1
    1-1. 如果執行時間比對參考資料來源Date Time (C欄)超過24H 能幫我反黃色標示嗎?
           我記得可以設定儲存格格式化條件(但我設了沒有作用)
2. 功能2
   2-1. 程式中報表上CUSTNAME 欄位(V欄位)中如果有 CSP / L1 / L2 / 字串則整個刪除
   2-2. 保留 ENG / HQCSP / HQ-CSP / HQ-L1 / HQ-L2 / HQL1 / HQL2
   2-3. 然後移去ENG 移至ENG資料表, HQ CSP系列移至CSP資料表, HQ L1 / HQ L2 系列移至Other資料表
3. 功能3
    3-1. 報表參考資料(ONHAND2HR_Ist_Flow)中的Q欄位QTY ,能比對 P欄位 STEP 帶入,
            程式中H欄~U欄位相對製程欄位嗎?   (如執行結果EXCEL) <重點功能>
4. 功能4
   4-1. 程式中,資料表FMC,前面有看見A欄位(PKG)與B欄位(MO) 已有合併儲存格, 發現後面有很多相同重複的 也可以合併嗎?
     4-1-1. V欄位(Custname)  W欄位(Device)  C欄位(Datetime) G欄位(MO QTY)   X欄位Substrate  Y欄位(B/D No)  Z欄位(Flow)


[attach]112667311[/attach]

作者: v03586    時間: 2016-1-22 01:57 AM

本帖最後由 v03586 於 2016-1-22 07:40 AM 編輯

已經將功能4問題解決...剩下求助[size=13.3333px]

更正功能3問題
3. 功能3
    3-1. 報表中的AA欄位QTY ,能比對 P欄位 STEP 帶入,H欄~U欄位相對製程欄位嗎?   
          EX: ( F9欄位=DB) AA數字70 ,  則帶入對應欄為 U欄(DB) U9顯示AA欄數字70
[attach]112690115[/attach]
  1. Dim UType%
  2. Sub 新報表_匯入()
  3. Dim xFile$, X As New Application, xB As Workbook, xS As Worksheet
  4. Dim RepSht As Worksheet, xR As Range, xLab As Range, xAddress$
  5. Set RepSht = Sheets("FMC")

  7. RepSht.UsedRange.EntireRow.Delete

  9. xFile = [comply!C3]
  10. If xFile = "" Then MsgBox "報表檔名稱未輸入！　": Exit Sub
  11. xFile = ThisWorkbook.Path & "\" & xFile & ".xls"
  12. If Dir(xFile) = "" Then MsgBox "找不到報表檔！　": Exit Sub
  13. Set xB = X.Workbooks.Open(xFile, ReadOnly:=True)
  14. Set xS = xB.Sheets(1)
  15. R = xS.Cells(Rows.Count, 1).End(xlUp).Row + 5
  16. Application.ScreenUpdating = False

  18. With RepSht
  19.      .Range("A1:A" & R) = xS.Range("AJ1:AJ" & R).Value  'pkg
  20.      .Range("B1:B" & R) = xS.Range("B1:B" & R).Value 'MO
  21.      
  22.      .Range("C1:C" & R).NumberFormatLocal = "@"   'Date time
  23.      .Range("C1:C" & R) = xS.Range("L1:L" & R).Value   'Date time
  24.      
  25.      .Range("D1:D" & R) = xS.Range("A1:A" & R).Value 'LOTID

  27.      .Range("E1:E" & R) = xS.Range("D1:D" & R).Value  'DIE TYPE
  28.      .Range("F1:F" & R) = xS.Range("P1:P" & R).Value   'STEP
  29.      .Range("G1:G" & R) = xS.Range("M1:M" & R).Value  ' MO QTY
  30.      .Range("AA1:AA" & R) = xS.Range("Q1:Q" & R).Value   '  QTY
  31.      .Range("H8").Value = "TBG1"
  32.      .Range("I8").Value = "PGH1"
  33.      .Range("J8").Value = "SLS1"
  34.      .Range("K8").Value = "WG"
  35.      .Range("L8").Value = "DE01"
  36.      .Range("M8").Value = "WM01"
  37.      .Range("N8").Value = "FL01"
  38.      .Range("O8").Value = "LWS1"
  39.      .Range("P8").Value = "WS01"
  40.      .Range("Q8").Value = "UTI1"
  41.      .Range("R8").Value = "VS01"
  42.      .Range("S8").Value = "QVS1"
  43.      .Range("T8").Value = "RQVS1"
  44.      .Range("U8").Value = "DB"
  45.      .Range("V1:W" & R) = xS.Range("E1:F" & R).Value  'CUST DEVICE
  46.      
  47.      
  48.      
  49.      .Range("X1:X" & R) = xS.Range("AD1:AD" & R).Value  'Substrate
  50.      .Range("Y1:Y" & R) = xS.Range("AE1:AE" & R).Value  'B/D No
  51.      .Range("Z1:Z" & R) = xS.Range("AQ1:AQ" & R).Value  'flow
  52.      
  53.      .Range("A8").Value = "PKG"
  54.      .Range("A7").Value = ""
  55.      .Range("X8").Value = "Substrate"
  56.      .Range("X7").Value = ""
  57.      .Range("Y8").Value = "B/D No."
  58.      .Range("Y7").Value = ""
  59.      .Range("D2").Value = ""
  60.      
  61.      .Range("A1").Value = "1ST Flow On Hand Report"
  62.      .Range("A2").Value = Now()
  63. '     For g = 3500 To 8 Step -1
  64. '        If .Cells(g, "V") Like "*CSP*" Or .Cells(g, "V") Like "*L1*" Or .Cells(g, "V") Like "*L2*" _
  65. '           Or .Cells(g, "V") Like "*ENG*" Or .Cells(g, "A") Like "LQFP*" Or .Cells(g, "A") Like "PLCC*" _
  66. '           Or .Cells(g, "A") Like "SOP*" Or .Cells(g, "A") Like "SSOP*" Or .Cells(g, "A") Like "TSOP*" _
  67. '           Or .Cells(g, "A") Like "TSSOP*" Then
  68. '            .Rows(g).Delete
  69. '        End If
  70. '     Next

  72. End With


  75. xB.Close 0


  78. Dim RR&, xArea As Range, xRR As Range, xH As Range, T, TT, XX
  79. RR = [FMC!A65536].End(xlUp).Row: If RR < 9 Then Exit Sub
  80. Set xArea = Sheets("FMC").Range("A9:A" & R)
  81. For Each xRR In xArea
  82.     T = xRR(1, 25): xRR(1, 25) = Mid(T, InStr(T, "-") + 1)
  83.     xRR(1, 24) = Right(xRR(1, 24), 9)
  84.       
  85.     T = xRR(1, 5):  T = Left(T, 2) & "-" & Mid(T, 24, 1) & "-" & Mid(T, 23, 4)
  86. '    TT = Application.VLookup(T, [Flow!A:B], 2, 0)
  87. '    If Not IsError(TT) Then xRR(1, 5) = TT Else xRR(1, 5).Font.Color = vbRed
  88.       
  89.     T = xRR(1, 11)
  90.     T = Mid(T & ",QVS", InStr(T, "QVS") + 4) '取 QVS 以後字串
  91.     For Each TT In Array("SPC", "SCL")
  92.         XX = InStr(T, TT): If XX > 0 Then xRR(1, 11) = Left(T, X + 2): Exit For
  93.     Next
  94. Next


  97. xArea.Resize(, 26).Sort Key1:=xArea(1, 1), Order1:=xlAscending, _
  98.                        Key2:=xArea(1, 25), Order2:=xlAscending, Header:=xlNo
  99.                         
  100. Application.DisplayAlerts = False
  101. For Each xRR In xArea
  102.     If xRR & xRR(1, 2) <> xRR(0) & xRR(0, 2) Then Set xH = xRR
  103.     If xRR & xRR(1, 2) <> xRR(2) & xRR(2, 2) Then
  104.       Range(xH, xRR).Merge: Range(xH(1, 2), xRR(1, 2)).Merge
  105.       Range(xH, xRR).Merge: Range(xH(1, 3), xRR(1, 3)).Merge
  106.       Range(xH, xRR).Merge: Range(xH(1, 7), xRR(1, 7)).Merge
  107.       Range(xH, xRR).Merge: Range(xH(1, 22), xRR(1, 22)).Merge
  108.       Range(xH, xRR).Merge: Range(xH(1, 23), xRR(1, 23)).Merge
  109.       Range(xH, xRR).Merge: Range(xH(1, 24), xRR(1, 24)).Merge
  110.       Range(xH, xRR).Merge: Range(xH(1, 25), xRR(1, 25)).Merge
  111.       Range(xH, xRR).Merge: Range(xH(1, 26), xRR(1, 26)).Merge
  112.       Range(xH, xRR(1, 26)).Borders.LineStyle = 1
  113.       For i = 7 To 10
  114.           Range(xH, xRR(1, 26)).Borders(i).Weight = xlMedium
  115.       Next i
  116.     End If
  117. Next
  118. With RepSht
  119.     Sheets("FMC").Select
  120.     Cells.Select
  121.     Selection.Font.Size = 14
  122.     With Selection.Font
  123.         .Name = "Arial"
  124.         .Size = 14
  125.         .Strikethrough = False
  126.         .Superscript = False
  127.         .Subscript = False
  128.         .OutlineFont = False
  129.         .Shadow = False
  130.         .Underline = xlUnderlineStyleNone
  131.         .ThemeColor = xlThemeColorLight1
  132.         .TintAndShade = 0
  133.         .ThemeFont = xlThemeFontNone
  134.     End With
  135.     Range("A8:Z8").Select
  136.     With Selection.Interior
  137.         .Pattern = xlSolid
  138.         .PatternColorIndex = xlAutomatic
  139.         .Color = 255
  140.         .TintAndShade = 0
  141.         .PatternTintAndShade = 0
  142.     End With
  143.     With Selection.Font
  144.         .ThemeColor = xlThemeColorDark1
  145.         .TintAndShade = 0
  146.     End With
  147. End With
  148.     Range("A8").Select
  149.     ActiveWindow.Zoom = 63

  151. Call 調整
  152.    
  153. End Sub

  155. Sub 報表_清除()
  156. Sheets("FMC").UsedRange.EntireRow.Delete
  157. End Sub



  161. Sub 調整()
  162. '
  163. ' 巨集1 巨集
  164. '
  165. Dim RepSht As Worksheet
  166. Set RepSht = Sheets("FMC")
  167. '
  168. With RepSht
  169.     Columns("A:A").Select
  170.     Selection.ColumnWidth = 30
  171.     Columns("B:B").Select
  172.     Selection.ColumnWidth = 11.63
  173.     Columns("C:C").Select
  174.     Selection.ColumnWidth = 16
  175.     Columns("D:D").Select
  176.     Selection.ColumnWidth = 20.88
  177.     Columns("E:E").Select
  178.     Selection.ColumnWidth = 8.25
  179.     Columns("F:F").Select
  180.     Selection.ColumnWidth = 9.25
  181.     Columns("G:G").Select
  182.     Selection.ColumnWidth = 10
  183.     Selection.NumberFormatLocal = "#,##0_ "
  184.     Columns("H:U").Select
  185.     Selection.ColumnWidth = 8.63
  186.     Columns("V:V").Select
  187.     Selection.ColumnWidth = 40.38
  188.     ActiveWindow.SmallScroll ToRight:=11
  189.     Columns("W:W").Select
  190.     Selection.ColumnWidth = 59.75
  191.     Columns("X:X").Select
  192.     Selection.ColumnWidth = 15.5
  193.     Columns("Y:Y").Select
  194.     Selection.ColumnWidth = 10.5
  195.     ActiveWindow.SmallScroll ToRight:=4
  196.     Columns("Z:Z").Select
  197.     Selection.ColumnWidth = 93.38
  198.     Range("A7").Select
  199. End With

  201. End Sub
複製代碼



作者: v03586    時間: 2016-1-23 02:06 AM

功能3我能想到的呈現方式就是
如果F欄未 [STEP] = TBG1 則就從AA欄位剪下貼上, 請問如何寫成多判斷
  1. For h = 9 To 3500
  2.         If .Cells(h, "F") = "TBG1" Then
  3.             .Cells(h, "AA").Select
  4.             Selection.Cut
  5.             .Cells(h, "H").Select
  6.             ActiveSheet.Paste
  7.         End If
  8.     next
複製代碼
我在下面在新增一個if  就跑不出來了
還有什麼辦法呢?或者如何修改?
  1. For h = 9 To 3500
  2.         If .Cells(h, "F") = "TBG1" Then
  3.             .Cells(h, "AA").Select
  4.             Selection.Cut
  5.             .Cells(h, "H").Select
  6.             ActiveSheet.Paste
  7.         End If
  8.         If .Cells(h, "F") = "PGH1" Then
  9.             .Cells(h, "AA").Select
  10.             Selection.Cut
  11.             .Cells(h, "I").Select
  12.             ActiveSheet.Paste
  13.         End If
  14.       Next
複製代碼
作者: rr09192084    時間: 2016-1-23 09:11 AM

  1. With ActiveSheet
  2.   For h = 9 To 3500
  3.    Select Case .Cells(h, "A").Value
  4.     Case "TBG1"
  5.      .Cells(h, "AA").Select
  6.      Selection.Cut
  7.      .Cells(h, "H").Select
  8.      ActiveSheet.Paste
  9.     Case "PGH1"
  10.      .Cells(h, "AA").Select
  11.      Selection.Cut
  12.      .Cells(h, "I").Select
  13.      ActiveSheet.Paste
  14.    End Select
  15.   Next
  16. End With
複製代碼
多重條件要確定是多選一，則用Select Case語法會比較適當。
作者: v03586    時間: 2016-1-23 11:41 AM

本帖最後由 v03586 於 2016-1-23 12:10 PM 編輯
rr09192084 發表於 2016-1-23 09:11 AM
多重條件要確定是多選一，則用Select Case語法會比較適當。

感謝大大指教

我寫完出現一個錯誤

[attach]112705755[/attach]

我的程式碼如下

  1. Dim RepSht As Worksheet, xR As Range, xLab As Range, xAddress$
  2. Set RepSht = Sheets("FMC")
  3. With RepSht
  4.      
  5.   For h = 9 To 3500
  6.    Select Case .Cells(h, "F").Value
  7.     Case "TBG1"
  8.      .Cells(h, "AA").Select
  9.      Selection.Cut
  10.      .Cells(h, "H").Select
  11.      ActiveSheet.Paste
  12.     Case "PGH1"
  13.      .Cells(h, "AA").Select
  14.      Selection.Cut
  15.      .Cells(h, "I").Select
  16.      ActiveSheet.Paste
  17.     Case "SLS1"
  18.      .Cells(h, "AA").Select
  19.      Selection.Cut
  20.      .Cells(h, "J").Select
  21.      ActiveSheet.Paste
  22.     Case "DE01"
  23.      .Cells(h, "AA").Select
  24.      Selection.Cut
  25.      .Cells(h, "L").Select
  26.      ActiveSheet.Paste
  27.     Case "WM01"
  28.      .Cells(h, "AA").Select
  29.      Selection.Cut
  30.      .Cells(h, "L").Select
  31.      ActiveSheet.Paste
  32.     Case "FL01"
  33.      .Cells(h, "AA").Select
  34.      Selection.Cut
  35.      .Cells(h, "N").Select
  36.      ActiveSheet.Paste
  37.     Case "LWS1"
  38.      .Cells(h, "AA").Select
  39.      Selection.Cut
  40.      .Cells(h, "O").Select
  41.      ActiveSheet.Paste
  42.     Case "WS01"
  43.      .Cells(h, "AA").Select
  44.      Selection.Cut
  45.      .Cells(h, "P").Select
  46.      ActiveSheet.Paste
  47.     Case "UTI1"
  48.      .Cells(h, "AA").Select
  49.      Selection.Cut
  50.      .Cells(h, "Q").Select
  51.      ActiveSheet.Paste
  52.     Case "VS01"
  53.      .Cells(h, "AA").Select
  54.      Selection.Cut
  55.      .Cells(h, "R").Select
  56.      ActiveSheet.Paste
  57.     Case "QVS1"
  58.      .Cells(h, "AA").Select
  59.      Selection.Cut
  60.      .Cells(h, "S").Select
  61.      ActiveSheet.Paste
  62.     Case "RQVS1"
  63.      .Cells(h, "AA").Select
  64.      Selection.Cut
  65.      .Cells(h, "T").Select
  66.      ActiveSheet.Paste
  67.     Case "DB"
  68.      .Cells(h, "AA").Select
  69.      Selection.Cut
  70.      .Cells(h, "U").Select
  71.      ActiveSheet.Paste
  72.    End Select
  73.   Next
  74.     For e = 9 To 3500
  75.       If .Cells(e, "F") Like "WG*" Then
  76.             .Cells(e, "AA").Select
  77.             Selection.Cut
  78.             .Cells(e, "K").Select
  79.             ActiveSheet.Paste
  80.       End If
  81.     Next


  84. End With
複製代碼


作者: rr09192084    時間: 2016-1-23 01:32 PM

本帖最後由 rr09192084 於 2016-1-23 01:38 PM 編輯

我記得以前這個問題就已經出現過了，要使用With就要把Sheet切換到那一張工作底稿上。
如：
  1. Set RepSht = Sheets("FMC")
  2. RepSht.Select
複製代碼
程式的最後再切換回來,不然就要用直接指定Sheet的方式。
另外，寫程式有點類似數學方程式的解法，相同的元素可以提出來，這個程式中每一個Case都會有這一段：
  1. .Cells(h, "AA").Select
  2. Selection.Cut
複製代碼
那麼就把這一段提出來，就像這樣：
  1. '把這一段提出來，如果沒有符合的條件，是不會執行貼上的動作的。
  2. .Cells(h, "AA").Select
  3. Selection.Cut
  4. Select Case .Cells(h, "F").Value
  5.     Case "TBG1"
  6.      .Cells(h, "H").Select
  7.      ActiveSheet.Paste
  8.     Case "PGH1"
  9.      .Cells(h, "I").Select
  10.      ActiveSheet.Paste
  11.     Case "SLS1"
  12.      .Cells(h, "J").Select
  13.      ActiveSheet.Paste
  14.     Case "DE01"
  15.      .Cells(h, "L").Select
  16.      ActiveSheet.Paste
  17. End Select
複製代碼
作者: v03586    時間: 2016-1-24 12:29 AM

本帖最後由 v03586 於 2016-1-24 12:30 AM 編輯
rr09192084 發表於 2016-1-23 01:32 PM
我記得以前這個問題就已經出現過了，要使用With就要把Sheet切換到那一張工作底稿上。
如：程式的最後再切換 ...

感謝大大指教...又讓我完成一項功能!!!!

剩下兩樣功能是否方便協助指教一下嗎
Q1.欄位線的劃置能全部細線條 , 依照B/D No 不同畫粗線條嗎?
   目前好像不同的MO 畫粗線
如圖片 原本是這樣
[attach]112714506[/attach]

讓他變成這種劃線方式
[attach]112714505[/attach]

1. 新增功能
   1-1. 程式中報表上CUSTNAME 欄位(V欄位)中如果只有 CSP / L1 / L2 / 字串則整個刪除
   1-2. 保留 ENG / HQCSP / HQ-CSP/ HQ-L1 / HQ-L2 / HQL1 / HQL2
   1-3. 然後移去ENG 移至ENG資料表, HQ CSP系列移至CSP資料表, HQ L1 / HQ L2 系列移至Other資料表
[attach]112714515[/attach]

  1. Dim UType%
  2. Sub 新報表_匯入()

  4. Dim xFile$, x As New Application, xB As Workbook, xS As Worksheet
  5. Dim RepSht As Worksheet, xR As Range, xLab As Range, xAddress$
  6. Set RepSht = Sheets("FMC")
  7. Application.ScreenUpdating = False
  8. RepSht.UsedRange.EntireRow.Delete
  9.     Dim currentPKG, currentDevice, whichFirst As String
  10.     Dim index As Integer
  11.     Dim hasReport As Boolean
  12.     title_row = 8
  13.     hasReport = False
  14.     For i = 1 To Workbooks.Count
  15.         With Workbooks(i).Sheets(1)
  16.             If .Range("A" & title_row).Value Like "LOTID*" And .Range("D" & title_row).Value Like "TYPE*" And .Range("M" & title_row) Like "QTY*" Then
  17.                 Set xS = Workbooks(i).Sheets(1)
  18.                 hasReport = True
  19.                 i = Workbooks.Count + 1
  20.             End If
  21.         End With
  22.     Next i
  23.     If hasReport = False Then MsgBox "找不到報表檔！　": Exit Sub
  24.     R = xS.Cells(Rows.Count, 1).End(xlUp).Row + 5
  25. With RepSht
  26.      .Range("A1:A" & R) = xS.Range("AJ1:AJ" & R).Value  'pkg
  27.      .Range("B1:B" & R) = xS.Range("B1:B" & R).Value 'MO
  28.      
  29.      .Range("C1:C" & R).NumberFormatLocal = "@"   'Date time
  30.      .Range("C1:C" & R) = xS.Range("L1:L" & R).Value   'Date time
  31.      
  32.      .Range("D1:D" & R) = xS.Range("A1:A" & R).Value 'LOTID

  34.      .Range("E1:E" & R) = xS.Range("D1:D" & R).Value  'DIE TYPE
  35.      .Range("F1:F" & R) = xS.Range("P1:P" & R).Value   'STEP
  36.      .Range("G1:G" & R) = xS.Range("M1:M" & R).Value  ' MO QTY
  37.      .Range("AA1:AA" & R) = xS.Range("Q1:Q" & R).Value   '  QTY
  38.      .Range("H8").Value = "TBG1"
  39.      .Range("I8").Value = "PGH1"
  40.      .Range("J8").Value = "SLS1"
  41.      .Range("K8").Value = "WG"
  42.      .Range("L8").Value = "DE01"
  43.      .Range("M8").Value = "WM01"
  44.      .Range("N8").Value = "FL01"
  45.      .Range("O8").Value = "LWS1"
  46.      .Range("P8").Value = "WS01"
  47.      .Range("Q8").Value = "UTI1"
  48.      .Range("R8").Value = "VS01"
  49.      .Range("S8").Value = "QVS1"
  50.      .Range("T8").Value = "RQVS1"
  51.      .Range("U8").Value = "DB"
  52.      .Range("V1:W" & R) = xS.Range("E1:F" & R).Value  'CUST DEVICE
  53.      .Range("X1:X" & R) = xS.Range("AD1:AD" & R).Value  'Substrate
  54.      .Range("Y1:Y" & R) = xS.Range("AE1:AE" & R).Value  'B/D No
  55.      .Range("Z1:Z" & R) = xS.Range("AQ1:AQ" & R).Value  'flow
  56.      .Range("A8").Value = "PKG"
  57.      .Range("A7").Value = ""
  58.      .Range("X8").Value = "Substrate"
  59.      .Range("X7").Value = ""
  60.      .Range("Y8").Value = "B/D No."
  61.      .Range("Y7").Value = ""
  62.      .Range("D2").Value = ""
  63.      .Range("AA8").Value = ""
  64.      .Range("A1").Value = "1ST Flow On Hand Report"
  65.      .Range("A2").Value = Now()
  66. End With

  68. Dim RRR&, xAArea As Range, xRRR As Range, xHH As Range, Q, TTTT, XXX
  69. RRR = [FMC!A65536].End(xlUp).Row: If RRR < 9 Then Exit Sub
  70. Set xAArea = Sheets("FMC").Range("A9:A" & RRR)
  71. For Each xRRR In xAArea
  72.     Q = xRRR(1, 26)
  73.     Q = Mid(Q & ",QVS", InStr(Q, "QVS") + 4) '取 QVS 以後字串
  74.     For Each TTTT In Array("SPC", "SCL")
  75.         XXX = InStr(Q, TTTT): If XXX > 0 Then xRRR(1, 26) = Left(Q, XXX + 2): Exit For
  76.     Next
  77. Next
  78. With RepSht
  79. '     For g = 3500 To 8 Step -1
  80. '        If .Cells(g, "V") Like "*CSP*" Or .Cells(g, "V") Like "*L1*" Or .Cells(g, "V") Like "*L2*" _
  81. '           Or .Cells(g, "V") Like "*ENG*" Or .Cells(g, "A") Like "LQFP*" Or .Cells(g, "A") Like "PLCC*" _
  82. '           Or .Cells(g, "A") Like "SOP*" Or .Cells(g, "A") Like "SSOP*" Or .Cells(g, "A") Like "TSOP*" _
  83. '           Or .Cells(g, "A") Like "TSSOP*" Or .Cells(g, "A") Like "TFBGA*" Then
  84. '            .Rows(g).Delete
  85. '        End If
  86. '     Next
  87. RepSht.Select
  88.   For h = 9 To 3500
  89.     .Cells(h, "AA").Select
  90.     Selection.Cut
  91.     Select Case .Cells(h, "F").Value
  92.     Case "TBG1"
  93.      .Cells(h, "H").Select
  94.      ActiveSheet.Paste
  95.     Case "PGH1"
  96.      .Cells(h, "I").Select
  97.      ActiveSheet.Paste
  98.     Case "SLS1"
  99.      .Cells(h, "J").Select
  100.      ActiveSheet.Paste
  101.     Case "DE01"
  102.      .Cells(h, "L").Select
  103.      ActiveSheet.Paste
  104.     Case "WM01"
  105.      .Cells(h, "L").Select
  106.      ActiveSheet.Paste
  107.     Case "FL01"
  108.      .Cells(h, "N").Select
  109.      ActiveSheet.Paste
  110.     Case "LWS1"
  111.      .Cells(h, "O").Select
  112.      ActiveSheet.Paste
  113.     Case "WS01"
  114.      .Cells(h, "P").Select
  115.      ActiveSheet.Paste
  116.     Case "UTI1"
  117.      .Cells(h, "Q").Select
  118.      ActiveSheet.Paste
  119.     Case "VS01"
  120.      .Cells(h, "R").Select
  121.      ActiveSheet.Paste
  122.     Case "QVS1"
  123.      .Cells(h, "S").Select
  124.      ActiveSheet.Paste
  125.     Case "RQVS1"
  126.      .Cells(h, "T").Select
  127.      ActiveSheet.Paste
  128.     Case "DB"
  129.      .Cells(h, "U").Select
  130.      ActiveSheet.Paste
  131.    End Select
  132.   Next
  133.     For e = 9 To 3500
  134.       If .Cells(e, "F") Like "WG*" Then
  135.             .Cells(e, "AA").Select
  136.             Selection.Cut
  137.             .Cells(e, "K").Select
  138.             ActiveSheet.Paste
  139.       End If
  140.     Next
  141. End With
  142. 'xB.Close 0
  143. Dim RR&, xArea As Range, xRR As Range, xH As Range, T, TT, XX
  144. RR = [FMC!A65536].End(xlUp).Row: If RR < 9 Then Exit Sub
  145. Set xArea = Sheets("FMC").Range("A9:A" & R)
  146. For Each xRR In xArea
  147.     T = xRR(1, 25): xRR(1, 25) = Mid(T, InStr(T, "-") + 1)
  148.     xRR(1, 24) = Right(xRR(1, 24), 9)
  149.       
  150.     T = xRR(1, 5):  T = Left(T, 2) & "-" & Mid(T, 24, 1) & "-" & Mid(T, 23, 4)
  151. Next
  152. xArea.Resize(, 26).Sort Key1:=xArea(1, 1), Order1:=xlAscending, _
  153.                        Key2:=xArea(1, 25), Order2:=xlAscending, Header:=xlNo
  154. Application.DisplayAlerts = False
  155. For Each xRR In xArea
  156.     If xRR & xRR(1, 2) <> xRR(0) & xRR(0, 2) Then Set xH = xRR
  157.     If xRR & xRR(1, 2) <> xRR(2) & xRR(2, 2) Then
  158.       Range(xH, xRR).Merge: Range(xH(1, 2), xRR(1, 2)).Merge
  159.       Range(xH, xRR).Merge: Range(xH(1, 3), xRR(1, 3)).Merge
  160.       Range(xH, xRR).Merge: Range(xH(1, 7), xRR(1, 7)).Merge
  161.       Range(xH, xRR).Merge: Range(xH(1, 22), xRR(1, 22)).Merge
  162.       Range(xH, xRR).Merge: Range(xH(1, 23), xRR(1, 23)).Merge
  163.       Range(xH, xRR).Merge: Range(xH(1, 24), xRR(1, 24)).Merge
  164.       Range(xH, xRR).Merge: Range(xH(1, 25), xRR(1, 25)).Merge
  165.       Range(xH, xRR).Merge: Range(xH(1, 26), xRR(1, 26)).Merge
  166.       Range(xH, xRR(1, 26)).Borders.LineStyle = 1
  167.       For i = 7 To 10
  168.           Range(xH, xRR(1, 26)).Borders(i).Weight = xlMedium
  169.       Next i
  170.     End If
  171. Next
  172. With RepSht
  173.     Sheets("FMC").Select
  174.     Cells.Select
  175.     Selection.Font.Size = 14
  176.     With Selection.Font
  177.         .Name = "Arial"
  178.         .Size = 14
  179.         .Strikethrough = False
  180.         .Superscript = False
  181.         .Subscript = False
  182.         .OutlineFont = False
  183.         .Shadow = False
  184.         .Underline = xlUnderlineStyleNone
  185.         .ThemeColor = xlThemeColorLight1
  186.         .TintAndShade = 0
  187.         .ThemeFont = xlThemeFontNone
  188.     End With
  189.     Range("A8:Z8").Select
  190.     With Selection.Interior
  191.         .Pattern = xlSolid
  192.         .PatternColorIndex = xlAutomatic
  193.         .Color = 255
  194.         .TintAndShade = 0
  195.         .PatternTintAndShade = 0
  196.     End With
  197.     With Selection.Font
  198.         .ThemeColor = xlThemeColorDark1
  199.         .TintAndShade = 0
  200.     End With
  201. End With
  202.     Range("A8").Select
  203.     ActiveWindow.Zoom = 63

  205. Call 調整
  206.    
  207. End Sub

  209. Sub 報表_清除()
  210. Sheets("FMC").UsedRange.EntireRow.Delete
  211. End Sub

  213. Sub 調整()
  214. Dim RepSht As Worksheet
  215. Set RepSht = Sheets("FMC")
  216. With RepSht
  217.     Columns("A:A").Select
  218.     Selection.ColumnWidth = 30
  219.     Columns("B:B").Select
  220.     Selection.ColumnWidth = 11.63
  221.     Columns("C:C").Select
  222.     Selection.ColumnWidth = 16
  223.     Columns("D:D").Select
  224.     Selection.ColumnWidth = 20.88
  225.     Columns("E:E").Select
  226.     Selection.ColumnWidth = 8.25
  227.     Columns("F:F").Select
  228.     Selection.ColumnWidth = 9.25
  229.     Columns("G:G").Select
  230.     Selection.ColumnWidth = 10
  231.     Selection.NumberFormatLocal = "#,##0_ "
  232.     Columns("H:U").Select
  233.     Selection.ColumnWidth = 8.63
  234.     Columns("V:V").Select
  235.     Selection.ColumnWidth = 40.38
  236.     ActiveWindow.SmallScroll ToRight:=11
  237.     Columns("W:W").Select
  238.     Selection.ColumnWidth = 59.75
  239.     Columns("X:X").Select
  240.     Selection.ColumnWidth = 15.5
  241.     Columns("Y:Y").Select
  242.     Selection.ColumnWidth = 10.5
  243.     ActiveWindow.SmallScroll ToRight:=4
  244.     Columns("Z:Z").Select
  245.     Selection.ColumnWidth = 93.38
  246.     Range("A7").Select
  247. End With

  249. End Sub
複製代碼







歡迎光臨 伊莉討論區 (http://a401.file-static.com/) Powered by Discuz!