Andy2483

¦^´_ 138# 198188


    ÁÂÁ«e½ú¸Ñ»¡,¥H¤U¬OFORM ¥N½X

Option Explicit
Dim A, Z, R&, W, L, i&, Brr, Mrr, Q, Drr, j%
Sub Form()
Dim Arr, Crr(1 To 100000, 1 To 18), xW$, S, T$, T2$, Ts, MyPath$, xFile$, xBook As Workbook, Re
Ts = Timer
Application.ScreenUpdating = False
Set Z = CreateObject("Scripting.Dictionary")
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
For i = 2 To UBound(Mrr): Z(Mrr(i, 3) & "/m") = i: Next
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
            Z(T & "|") = Trim(Mid(Brr(2, j), 1, Len(Brr(2, j)) * 2 - LenB(StrConv(Brr(2, j), vbFromUnicode)) - 2))
         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
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 Else T = Brr(i, 16)
      R = R + 1: A(R, 1) = R: Run Replace(Z(T & "/s"), " ", "_")
      If T <> Brr(i + 1, 16) Then
         If xW = "" Then Workbooks.Add: xW = ActiveWorkbook.Name
         ThisWorkbook.Sheets(Z(T & "/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 Else T = Drr(i, 9)
      R = R + 1: A(R, 1) = R: Run Replace(Z(T & "/s"), " ", "_")
      If T <> Drr(i + 1, 9) Then
         If xW = "" Then Workbooks.Add: xW = ActiveWorkbook.Name
         ThisWorkbook.Sheets(Z(T & "/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 "¦@¯Ó®É¡G" & 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
   For j = 0 To 5: A(R, Array(4, 5, 6, 8, 9, 13)(j)) = Mrr(Z(A(R, 3) & "/m"), Array(5, 6, 7, 11, 10, 8)(j)): Next
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()
For j = 0 To 5: A(R, Array(2, 9, 6, 7, 11, 3)(j)) = Brr(i, Array(1, 3, 5, 6, 7, 12)(j)): Next
If A(R, 3) <> "" And Z.Exists(A(R, 3) & "/m") Then
   For j = 0 To 2: A(R, Array(4, 5, 8)(j)) = Mrr(Z(A(R, 3) & "/m"), Array(5, 6, 8)(j)): Next
End If
End Sub

Sub Structural()
For j = 0 To 2: A(R, Array(2, 3, 5)(j)) = Brr(i, Array(1, 2, 3)(j)): Next
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()
For j = 0 To 3: A(R, Array(2, 3, 4, 7)(j)) = Brr(i, Array(1, 12, 5, 3)(j)): Next
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()
For j = 0 To 5: A(R, Array(2, 3, 4, 5, 6, 7)(j)) = Brr(i, Array(1, 11, 10, 4, 3, 1)(j)): Next
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()
For j = 0 To 4: A(R, Array(2, 3, 4, 5, 7)(j)) = Drr(i, Array(2, 3, 4, 5, 6)(j)): Next
End Sub

Andy2483

¦^´_ 140# 198188


    ½d¨ÒÀÉ°õ¦æ¨S°ÝÃD! ¥Î¥H¤U±ø¥ó°õ¦æDATA«á ¦b°õ¦æ FORM ¤]¨S°ÝÃD

§å¦¸¦¸§Ç        ¼Ó¼h        ¥Í²£³æ¸¹
A                   03F-41F        WO-J057-020

Andy2483

¦^´_ 142# 198188


    Z(T & "/s") ¬O­^¤å
xW ¬O·s¼W ¬¡­¶Ã¯¦WºÙ(¨Ì·Ó©Ò¨Ï¥Î»y¨¥·s¼Wªº¦W¦r)

Andy2483

¦^´_ 145# 198188


    ¥X¿ù¦ì¸mªºT­È ¬O¤°»ò¦r¦ê,xW¬O¤°»ò¦r¦ê?

Andy2483

¦^´_ 147# 198188


    ¥Dµ{¦¡´«¦¨¥H¤U¥N½X,½Ð¸Õ¸Õ¬Ý
Option Explicit
Dim A, Z, R&, W, L, i&, Brr, Mrr, Q, Drr, j%
Sub Form()
Dim Arr, Crr(1 To 100000, 1 To 18), xW$, S, T$, T2$, Ts, MyPath$, xFile$, xBook As Workbook, Re
Ts = Timer
Application.ScreenUpdating = False
Set Z = CreateObject("Scripting.Dictionary")
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
For i = 2 To UBound(Mrr): Z(Mrr(i, 3) & "/m") = i: Next
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
            Z(T & "|") = Trim(Mid(Brr(2, j), 1, Len(Brr(2, j)) * 2 - LenB(StrConv(Brr(2, j), vbFromUnicode)) - 2))
         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
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 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
         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 Else T = Drr(i, 9)
      R = R + 1: A(R, 1) = R: Run Replace(Z(T & "/s"), " ", "_")
      If T <> Drr(i + 1, 9) 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
         End With
         A = Crr: R = 0
      End If
   Next
End With
Set Z = Nothing
Erase Arr, Brr, Crr, Drr, A, Mrr
MsgBox "¦@¯Ó®É¡G" & Timer - Ts & " ¬í"
End Sub

Andy2483

¦^´_ 147# 198188


    §â¶Ã½Xªº¤u§@ªí¦W§ï±¼¸Õ¸Õ¬Ý

¤U¸ü (57.89 KB)

2025-11-3 16:43

Andy2483

¦^´_ 151# 198188


    ³Ò·Ð«e½ú±N¥þ³¡¸ê®Æ½Æ»s¤@¥÷¨ì·s¼W¬¡­¶Ã¯ª½¨ì¤u§@ªí¦W¨S¦³¶Ã½X¡A¦A½Æ»s¥N½X°õ¦æ¬Ý¬Ý

Andy2483

¦^´_ 151# 198188


    FORM Åܧó¦p¤U:

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
Ts = Timer
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-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 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
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 Else T = Drr(i, 9)
      R = R + 1: A(R, 1) = R: Run Replace(Z(T & "/s"), " ", "_")
      If T <> Drr(i + 1, 9) 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
Set Z = Nothing
Erase Arr, Brr, Crr, Drr, A, Mrr
MsgBox "¦@¯Ó®É¡G" & Timer - Ts & " ¬í"
End Sub
'________________________________________________________
Sub RuleRun()
Dim T$, T2$, S$, i&, j%
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
            Z(T & "^") = Brr(2, j)
            Z(T & "|") = Trim(Mid(Brr(2, j), 1, Len(Brr(2, j)) * 2 - LenB(StrConv(Brr(2, j), vbFromUnicode)) - 2))
         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 & "|")
         Z(T2 & "/EC") = Brr(i, 9) & "-" & Brr(i, 10)
         Z(T2 & "/ER") = Z(T & "^")
      End If
      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
      Z(S & "/V1") = Switch(S = "Bom", "A4", S = "Gasket", "D6", S = "Structural", "C3", S = "Fabrication Extrusion", "A3", S = "Finish", "A3", S = "DN Material", "A3")
      Z(S & "/V2") = Switch(S = "Bom", "A5", S = "Gasket", "D7", S = "Structural", "C4", S = "Fabrication Extrusion", "A4", S = "Finish", "A4", S = "DN Material", "A4")
   Next
Next
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
   For j = 0 To 5: A(R, Array(4, 5, 6, 8, 9, 13)(j)) = Mrr(Z(A(R, 3) & "/m"), Array(5, 6, 7, 11, 10, 8)(j)): Next
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()
For j = 0 To 5: A(R, Array(2, 9, 6, 7, 11, 3)(j)) = Brr(i, Array(1, 3, 5, 6, 7, 12)(j)): Next
If A(R, 3) <> "" And Z.Exists(A(R, 3) & "/m") Then
   For j = 0 To 2: A(R, Array(4, 5, 8)(j)) = Mrr(Z(A(R, 3) & "/m"), Array(5, 6, 8)(j)): Next
End If
End Sub

Sub Structural()
For j = 0 To 2: A(R, Array(2, 3, 5)(j)) = Brr(i, Array(1, 2, 3)(j)): Next
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()
For j = 0 To 3: A(R, Array(2, 3, 4, 7)(j)) = Brr(i, Array(1, 12, 5, 3)(j)): Next
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()
For j = 0 To 5: A(R, Array(2, 3, 4, 5, 6, 7)(j)) = Brr(i, Array(1, 11, 10, 4, 3, 1)(j)): Next
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()
For j = 0 To 4: A(R, Array(2, 3, 4, 5, 7)(j)) = Drr(i, Array(2, 3, 4, 5, 6)(j)): Next
End Sub

Andy2483

¦^´_ 151# 198188


    PDFÀɲ£¥X¤è®×¦p¤U:

Option Explicit
Sub Print_PDF()
Dim T$, NewMyPath, Pj, PP$, Dn$
Application.ScreenUpdating = False
Call RuleRun

Dn = Format(Now, "yyyy_mm_dd_hh_nn_ss")
Pj = ['WO No'!A2].Resize(, 11): Pj = Replace(Join(Application.Transpose(Application.Transpose(Pj)), "_"), "/", "_")
NewMyPath = ThisWorkbook.Path & "\" & Pj & "\"
If Dir(NewMyPath, vbDirectory) = "" Then MkDir NewMyPath
NewMyPath = NewMyPath & Dn & "\"
MkDir NewMyPath
For i = Worksheets.Count To 1 Step -1
   T = Sheets(i).Name & "/s"
   If Z(T) <> "" Then
      Sheets(i).ExportAsFixedFormat Type:=xlTypePDF, Filename:=NewMyPath & Z(Sheets(i).Name & "/") & "_" & Dn & ".pdf", _
      Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
   End If
Next
MsgBox "PDF_Save_Address: " & vbLf & NewMyPath
End Sub

Andy2483

¦^´_ 151# 198188


    Dataªº­×§ï¤è®×¤]´£¨Ñ°Ñ¦Ò:

Sub Data()
Dim Arr, Brr, Crr, Z, Q, S, i&, j%, N&, T$, T1$, MyPath$, xFile$, xBook As Workbook, Re, R&
Application.ScreenUpdating = False
For Each S In [{"Layout Dwg","Frame per Dwg","Part List"}]
   Sheets(S).UsedRange.Rows.Offset(1).EntireRow.Delete
Next
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
Set Z = CreateObject("Scripting.Dictionary")
T = Sheets("Read").[A2] & "|" & Sheets("Read").[C2]
T1 = Sheets("Read").[B2]
With xBook.Sheets("WO No")
   For i = 2 To .[A65536].End(3).Row
      If .Cells(i, "B") & "|" & .Cells(i, "D") = T Then
         .Rows(i).Copy Sheets("WO No").Rows(2)
         For j = 6 To 11
            Z("|" & .Cells(i, j)) = ""
         Next
         Sheets("Read").[A2].Resize(, 3).Copy Sheets("WO No").[B2]
         GoTo 11
      End If
   Next
   MsgBox "Nothing": Exit Sub
End With
11
If T1 Like "##F-*##F" Then
   For i = Val(T1) To Val(StrReverse(Mid(StrReverse(T1), 2, 2)))
      Z(Format(i, "00F")) = ""
   Next
   Else
      Q = Split(T1 & "&" & T1, "&")
      For i = 0 To UBound(Q)
         Z(Q(i)) = 0
      Next
End If
Brr = xBook.Sheets("Layout Dwg").UsedRange
For i = 2 To UBound(Brr)
   If Z.Exists(Brr(i, 2)) And Brr(i, 4) = Sheets("Read").[A2] Then
      Z(Brr(i, 1)) = Z(Brr(i, 1)) + Val(Brr(i, 3))
      N = N + 1
      For j = 1 To 4: Brr(N, j) = Brr(i, j): Next
      Z(Brr(N, 1) & "||") = 1
   End If
Next
If N > 0 Then Sheets("Layout Dwg").[A2].Resize(N, 4) = Brr: N = 0 Else MsgBox "Nothing under the floor": GoTo 12
Set Brr = xBook.Sheets("Frame per Dwg").UsedRange
Brr = Range(Brr, Brr.Offset(, 1))
For i = 2 To UBound(Brr)
   If Z(Brr(i, 1)) > 0 Then
      N = N + 1
      For j = 1 To 6: Brr(N, j) = Brr(i, j): Next
      Brr(N, 7) = Brr(N, 5) & " x " & Z(Brr(i, 1))
      Brr(N, 5) = Brr(N, 5) * Z(Brr(i, 1))
      Z(Brr(i, 2) & "/") = Z(Brr(i, 2) & "/") + Brr(N, 5)
      Z(Brr(i, 1) & "||") = Z(Brr(i, 1) & "||") + 1
   End If
Next
If N > 0 Then Sheets("Frame per Dwg").[A2].Resize(N, 7) = Brr: N = 0 Else MsgBox "Frame per Dwg_Nothing"
Brr = xBook.Sheets("Part List").UsedRange
ReDim Arr(1 To 100000, 1 To 14): Crr = Arr
For i = 2 To UBound(Brr)
   T = Brr(i, 8)
   If T Like "*[a-z]" Then Q = Left(T, Len(T) - 1) Else Q = "||"
   If Z(T & "||") = 1 Or Z(Q) > 0 Then
      N = N + 1
      For j = 1 To 13: Arr(N, j) = Brr(i, j): Next
      Arr(N, 14) = Arr(N, 3) & " x " & (Z(T) + Z(Q))
      Arr(N, 3) = Arr(N, 3) * (Z(T) + Z(Q))
   End If
   If Z(T & "/") > 0 And Z.Exists("|" & Left(T, 2)) Then
      R = R + 1
      For j = 1 To 13: Crr(R, j) = Brr(i, j): Next
      Crr(R, 14) = Crr(R, 3) & " x " & Z(T & "/")
      Crr(R, 3) = Crr(R, 3) * Z(T & "/")
   End If
Next
If N > 0 Then
   With Sheets("Part List").[A2].Resize(N, 14)
      .Value = Arr
      .Interior.ColorIndex = 35
   End With
End If
If R > 0 Then
   With Sheets("Part List").Cells(N + 2, 1).Resize(R, 14)
      .Value = Crr
      .Interior.ColorIndex = 36
   End With
End If
If N + R = 0 Then MsgBox "Part List_Nothing"
12: If Re = True Then xBook.Close 0
End Sub