- 帖子
- 1567
- 主題
- 40
- 精華
- 0
- 積分
- 1591
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-11-25
|
本帖最後由 Andy2483 於 2025-10-27 15:39 編輯
回復 45# 198188
以下方案請試試看:
Option Explicit
Dim A, Z, R&, W, L, i&, Brr, Mrr, Q, Drr
Sub TEST()
Dim Arr, Crr(1 To 100000, 1 To 18), V, xW$, S, j%, C%, y%, K, X%, T$, T1$, T2$, T3$, T4$, T5$, Ts
Ts = Timer
Application.ScreenUpdating = False
Set Z = CreateObject("Scripting.Dictionary")
Brr = [Rule!A1].CurrentRegion
For i = 3 To UBound(Brr)
For j = 2 To 8
T = Brr(i, j)
If T <> "" Then
If Z(T & "|") = "" Then
T1 = Trim(Mid(Brr(2, j), 1, Len(Brr(2, j)) * 2 - LenB(StrConv(Brr(2, j), vbFromUnicode)) - 2))
Z(T & "|") = T1
End If
Exit For
End If
Next
For j = 11 To 28
If Brr(i, j) = "" Then Exit For
T2 = Brr(i, 11) & "-" & T
Z(Brr(i, j) & "-" & T) = T2
If Z(T2 & "/") = "" Then Z(T2 & "/") = Brr(i, 9) & "-" & Z(T & "|")
S = Brr(i, 1)
Z(T2 & "/s") = S
Z(S & "/UR") = Sheets(S).[A65536].End(3)(2).Row
Z(S & "/UC") = Sheets(S).Cells(Z(S & "/UR") - 1, 256).End(xlToLeft).Column
Next
Next
Mrr = Sheets("Material").UsedRange
For i = 2 To UBound(Mrr)
Z(Mrr(i, 3) & "/m") = i
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-O", 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
T = Brr(i, 16)
R = R + 1: A(R, 1) = R: Run Replace(Z(T & "/s"), " ", "_")
If Brr(i, 16) <> Brr(i + 1, 16) Then
If xW = "" Then
Workbooks.Add
xW = ActiveWorkbook.Name
End If
ThisWorkbook.Sheets(Z(Brr(i, 16) & "/s")).Copy Before:=Workbooks(xW).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
End With
A = Crr
R = 0
End If
Next
End With
ThisWorkbook.Activate
If Sheets("Frame per Dwg").FilterMode = True Then Sheets("Frame per Dwg").ShowAllData
With Range(Sheets("Frame per Dwg").[I1], Sheets("Frame per Dwg").[A65536].End(3)(2))
With .Columns(8): .Cells = "=ROW()": .Value = .Value: End With
Drr = .Value
ReDim Arr(1 To UBound(Drr) - 1, 1 To 1)
For i = 2 To UBound(Drr)
T = Left(Drr(i, 2), 2) & "-" & Drr(i, 6)
If InStr("WT", Right(T, 1)) Then Arr(i - 1, 1) = Z(T)
Next
.Cells(2, 9).Resize(UBound(Drr) - 1, 1) = Arr
.Sort KEY1:=.Item(9), Order1:=1, Header:=1
Drr = .Value
.Sort KEY1:=.Item(8), Order1:=1, Header:=1
.Cells(1, 8).Resize(, 2).EntireColumn.Delete
A = Crr: R = 0
For i = 2 To UBound(Drr) - 1
If Drr(i, 9) = "" Then Exit For
T = Drr(i, 9)
R = R + 1: A(R, 1) = R: Run Replace(Z(T & "/s"), " ", "_")
If Drr(i, 9) <> Drr(i + 1, 9) Then
If xW = "" Then
Workbooks.Add
xW = ActiveWorkbook.Name
End If
ThisWorkbook.Sheets(Z(Drr(i, 9) & "/s")).Copy Before:=Workbooks(xW).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
End With
A = Crr
R = 0
End If
Next
End With
Set Z = Nothing
Erase Arr, Brr, Crr, Drr, A, Mrr
MsgBox "共耗時：" & Timer - Ts & " 秒"
End Sub
Sub Bom()
A(R, 2) = Brr(i, 1)
A(R, 3) = Brr(i, 12)
If A(R, 3) <> "" And Z.Exists(A(R, 3) & "/m") Then
A(R, 4) = Mrr(Z(A(R, 3) & "/m"), 5)
A(R, 5) = Mrr(Z(A(R, 3) & "/m"), 6)
A(R, 6) = Mrr(Z(A(R, 3) & "/m"), 7)
A(R, 8) = Mrr(Z(A(R, 3) & "/m"), 11)
A(R, 9) = Mrr(Z(A(R, 3) & "/m"), 10)
A(R, 13) = Mrr(Z(A(R, 3) & "/m"), 8)
End If
A(R, 7) = Brr(i, 4) & " x " & Brr(i, 5)
A(R, 10) = Brr(i, 3)
A(R, 18) = Brr(i, 7)
End Sub
Sub Gasket()
A(R, 2) = Brr(i, 1)
A(R, 9) = Brr(i, 3)
A(R, 6) = Brr(i, 5)
A(R, 7) = Brr(i, 6)
A(R, 11) = Brr(i, 7)
A(R, 3) = Brr(i, 12)
If A(R, 3) <> "" And Z.Exists(A(R, 3) & "/m") Then
A(R, 4) = Mrr(Z(A(R, 3) & "/m"), 5)
A(R, 5) = Mrr(Z(A(R, 3) & "/m"), 6)
A(R, 8) = Mrr(Z(A(R, 3) & "/m"), 8)
End If
End Sub
Sub Structural()
A(R, 2) = Brr(i, 1)
A(R, 3) = Brr(i, 2)
A(R, 5) = Brr(i, 3)
L = Split(Brr(i, 2) & "mm", "mm")(0)
W = Split(Brr(i, 2) & "mm", "mm")(1)
L = Val(StrReverse(Mid(Val(StrReverse(L & 1)), 2)))
W = Val(StrReverse(Mid(Val(StrReverse(W & 1)), 2)))
A(R, 6) = L * W
A(R, 8) = A(R, 5) * A(R, 6) / 1000
A(R, 7) = Application.RoundUp(A(R, 5) * A(R, 6) / 1000, 0)
End Sub
Sub DN_Material()
A(R, 2) = Brr(i, 1)
A(R, 3) = Brr(i, 12)
A(R, 4) = Brr(i, 5)
A(R, 7) = Brr(i, 3)
If A(R, 3) <> "" And Z.Exists(A(R, 3) & "/m") Then
A(R, 5) = Mrr(Z(A(R, 3) & "/m"), 11)
A(R, 6) = Mrr(Z(A(R, 3) & "/m"), 8)
A(R, 8) = A(R, 5) * A(R, 7)
End If
A(R, 9) = Brr(i, 7)
End Sub
Sub Fabrication_Extrusion()
A(R, 2) = Brr(i, 1)
A(R, 3) = Brr(i, 11)
A(R, 4) = Brr(i, 10)
A(R, 5) = Brr(i, 4)
A(R, 6) = Brr(i, 3)
A(R, 7) = Brr(i, 1)
If A(R, 7) Like "*-*-*" Then
Q = Split(A(R, 7), "-")
A(R, 7) = Q(0) & "-" & Q(1)
End If
A(R, 8) = Brr(i, 7)
End Sub
Sub Finish()
A(R, 2) = Drr(i, 2)
A(R, 3) = Drr(i, 3)
A(R, 4) = Drr(i, 4)
A(R, 5) = Drr(i, 5)
A(R, 7) = Drr(i, 6)
End Sub |
|
發表於 2025-10-23 08:43
| 