- 帖子
- 1537
- 主題
- 40
- 精華
- 0
- 積分
- 1561
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-11-6
|
回復 165# 198188
1） Form 是 根據 本檔 Part List 的 A 欄 加工件編號 和 G 欄 備注 來導出 Form
前輩的程式，連 Frame per Dwg 也導出 Form 了，這部分不需要 (以附件的例子，WS-T, WA-W, FS-W, FG-W, FA-W 裏面的編號 是不在Part List 裏面，所以不要制表)
前輩沒有用行業話術說明為什麼不需要,只能用字面上的意思猜需求,括弧()裡的意義無法理解,以下方案請參考
Option Explicit
Public A, Z, R&, W, L, i&, Brr, Mrr, Q, Drr, j%, MyPath$
Sub Form()
Dim Arr, Crr(1 To 100000, 1 To 18), xW$, S, T$, T2$, Ts, xFile$, xBook As Workbook, Re
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyPath = ThisWorkbook.Path & "\"
xFile = "Data Base.xlsx"
On Error Resume Next
Set xBook = Workbooks(xFile)
If xBook Is Nothing Then
Set xBook = Workbooks.Open(MyPath & xFile, , True, , "")
Re = True: ThisWorkbook.Activate
End If
On Error GoTo 0
Mrr = xBook.Sheets("Material").UsedRange
If Re = True Then xBook.Close 0
Call RuleRun
For i = 2 To UBound(Mrr): Z(Mrr(i, 3) & "/m") = i: Next
For i = Worksheets.Count To 1 Step -1
If Z(Sheets(i).Name & "/s") <> "" Then Sheets(i).Delete
Next
If Sheets("Part List").FilterMode = True Then Sheets("Part List").ShowAllData
With Range(Sheets("Part List").[P1], Sheets("Part List").[A65536].End(3)(2))
With .Columns(15): .Cells = "=ROW()": .Value = .Value: End With
Brr = .Value
ReDim Arr(1 To UBound(Brr) - 1, 1 To 1)
For i = 2 To UBound(Brr)
T = Left(Brr(i, 1), 2) & "-" & Brr(i, 7)
If InStr("Y-OWT", Right(T, 1)) Then Arr(i - 1, 1) = Z(T)
Next
.Cells(2, 16).Resize(UBound(Brr) - 1, 1) = Arr
.Sort KEY1:=.Item(16), Order1:=1, Header:=1
Brr = .Value
.Sort KEY1:=.Item(15), Order1:=1, Header:=1
.Cells(1, 15).Resize(, 2).EntireColumn.Delete
A = Crr
For i = 2 To UBound(Brr) - 1
If Brr(i, 16) = "" Then Exit For Else T = Brr(i, 16)
R = R + 1: A(R, 1) = R: Run Replace(Z(T & "/s"), " ", "_")
If T <> Brr(i + 1, 16) Then
Sheets(Z(T & "/s")).Copy Before:=Sheets(1)
ActiveSheet.Name = T
With Cells(Z(Z(T & "/s") & "/UR"), 1).Resize(R, Z(Z(T & "/s") & "/UC"))
.Value = A
.Borders.LineStyle = xlContinuous
ActiveSheet.PageSetup.PrintArea = Range([A1], .Cells).Address
End With
With Range(Z(Z(T & "/s") & "/V1")): .Value = Z(T & "/EC"): .ShrinkToFit = True: End With
With Range(Z(Z(T & "/s") & "/V2")): .Value = Z(T & "/ER"): .ShrinkToFit = True: End With
A = Crr: R = 0
End If
Next
End With
ThisWorkbook.Activate
Set Z = Nothing
Erase Arr, Brr, Crr, A, Mrr
End Sub |
|
發表於 
