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

標題: 請問規則02F - 04F 如果在Data Base 篩選在這個範圍内的相關資料 [打印本頁]

作者: 198188 時間: 2025-10-5 16:17 標題: 請問規則02F - 04F 如果在Data Base 篩選在這個範圍内的相關資料

[attach]38095[/attach][attach]38096[/attach][attach]38097[/attach]

請問如果規則是02F - 04F 或者多個樓層，如果在Data Base 篩選在這個範圍内的相關資料。
如圖一，圖二，圖三
附上Excel Data Base & 想要的結果及規則。

作者: 198188 時間: 2025-10-5 16:20

[attach]38101[/attach][attach]38102[/attach][attach]38103[/attach]

作者: hcm19522 時間: 2025-10-6 11:19

B2=VLOOKUP($A2,'[Data Base.xlsx]WO No'!$A:$K,COLUMN(B1),)

作者: 198188 時間: 2025-10-6 11:36

本帖最後由 198188 於 2025-10-6 11:38 編輯

[attach]38104[/attach]

B2=VLOOKUP($A2,'[Data Base.xlsx]WO No'!$AK,COLUMN(B1),)
hcm19522 發表於 2025-10-6 11:19

這個并非我的問題要求。
我意思是說，
我輸入02F-04F （圖1)
就會自動抽取 Layout Dwg 表裏欄 B 樓層屬於這個 02F - 04F 範圍内的資料出來（圖3）

我輸入03F-08F（圖1)
就會自動抽取 Layout Dwg 表裏欄 B 樓層屬於這個 03F - 08F 範圍内的資料出來（圖3）

作者: 198188 時間: 2025-10-8 09:11

本帖最後由 198188 於 2025-10-8 09:16 編輯

Sub Copy_Layout_To_Data() 'ok!
Dim h, i, j As Integer
Dim myString, myString1 As String
Dim charToFind, charToFind1, charToFind2 As String
Dim position, position1, position2, position3 As Long
Dim stringLength, stringLength1 As Long
j = 2
h = Worksheets("Layout Dwg").Cells(Rows.Count, 1).End(3).Row
h = h + 1
myString = Sheets("Data").Range("C2")
stringLength = Len(myString)
charToFind = "-" ' Searching for lowercase '-' in "World"
position = InStr(1, myString, charToFind, vbTextCompare)
If position > 0 Then
a = Mid(myString, 1, position - 2)
b = Mid(myString, position + 1, stringLength - position - 1)
For i = 2 To h
Sheets("Layout Dwg").Select
myString1 = Range("B" & i)
charToFind2 = "F" ' Searching for lowercase 'F' in "World"
position2 = InStr(1, myString1, charToFind2, vbTextCompare)
If position2 > 0 Then
c = Mid(myString1, 1, position2 - 1)
If c = a Then
Sheets("Layout Dwg").Select
Range("A" & i & ":C" & i).Select
Selection.Copy
Sheets("Data").Select
Range("M" & j).Select
ActiveSheet.Paste
j = j + 1
Else
If c > a And c <= b Then
Sheets("Layout Dwg").Select
Range("A" & i & ":C" & i).Select
Selection.Copy
Sheets("Data").Select
Range("M" & j).Select
ActiveSheet.Paste
j = j + 1
End If
End If
End If
Next i
Else
charToFind1 = "&" ' Searching for lowercase '&' in "World"
position1 = InStr(1, myString, charToFind1, vbTextCompare)
If position1 > 0 Then
Z = Mid(myString, 1, position1 - 1)
y = Mid(myString, position1 + 1, stringLength - position1)
For i = 2 To h
Sheets("Layout Dwg").Select
c = Range("B" & i)
If c = Z Or c = y Then
Sheets("Layout Dwg").Select
Range("A" & i & ":C" & i).Select
Selection.Copy
Sheets("Data").Select
Range("M" & j).Select
ActiveSheet.Paste
j = j + 1
End If
Next i
Else
W = myString
For i = 2 To h
Sheets("Layout Dwg").Select
c = Range("B" & i)
If c = W Then
Sheets("Layout Dwg").Select
Range("A" & i & ":C" & i).Select
Selection.Copy
Sheets("Data").Select
Range("M" & j).Select
ActiveSheet.Paste
j = j + 1
End If
Next i
End If
End If
End Sub

複製代碼

這個并非我的問題要求。
我意思是說，
我輸入02F-04F （圖1)
就會自動抽取 Layout Dwg 表裏欄 B 樓層 ...
198188 發表於 2025-10-6 11:36

嘗試用這個方式可以區別，但是運行速度太慢，請教各大大有沒有改進空間？

作者: Andy2483 時間: 2025-10-8 14:54

本帖最後由 Andy2483 於 2025-10-8 15:28 編輯

回復 2# 198188

謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考

Option Explicit
Sub TEST()
Dim Brr, Z, Q, i&, j%, N&, T$, T1$, MyPath$, xFile$, xBook As Workbook, MyBook As Workbook, Re
Set Z = CreateObject("Scripting.Dictionary")
Set MyBook = ThisWorkbook
MyPath = MyBook.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
MyBook.Activate
End If
On Error GoTo 0
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)
      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").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z.Exists(Brr(i, 2)) Then
   Z(Brr(i, 1)) = Z(Brr(i, 1)) + Val(Brr(i, 3))
   N = N + 1
   For j = 1 To 3: Brr(N, j) = Brr(i, j): Next
End If
Next
If N > 0 Then Sheets("Layout Dwg").[K2].Resize(N, 3) = Brr: N = 0 Else MsgBox "Nothing2": GoTo 12
Brr = xBook.Sheets("Frame per Dwg").[A1].CurrentRegion
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, 5) = Brr(N, 5) * Z(Brr(i, 1))
End If
Next
If N > 0 Then Sheets("Frame per Dwg").[N2].Resize(N, 6) = Brr: N = 0
Brr = xBook.Sheets("Part List").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z(Brr(i, 7)) > 0 Then
   N = N + 1
   For j = 1 To 13: Brr(N, j) = Brr(i, j): Next
   Brr(N, 3) = Brr(N, 3) * Z(Brr(i, 7))
End If
Next
If N > 0 Then Sheets("Part List").[U2].Resize(N, 13) = Brr
12: If Re = True Then xBook.Close 0
End Sub

作者: 198188 時間: 2025-10-8 16:29

本帖最後由 198188 於 2025-10-8 16:49 編輯

回復 198188

謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考

...
Andy2483 發表於 2025-10-8 14:54

感謝前輩指點

作者: 198188 時間: 2025-10-9 17:30

回復 198188

謝謝前輩發表此主題與範例
後學藉此帖練習陣列與字典,學習方案如下,請前輩參考

...
Andy2483 發表於 2025-10-8 14:54

[attach]38112[/attach]

前輩你好，檢視後，發現有兩點漏了提出，
Layout Dwg 需要加一個篩選條件 “批次”

Part List 需要增加一個資料：篩選條件是，WO-No 欄F - 欄K 的各樣數據字母，舉例 WO-J057-022 裏面有 "WS" 根據 Frame Per Dwg 裏面的組裝圖號含有“WS”，在Part List 對應組裝號/加工件號篩選出來（只顯示各樣數據有的相關字母）數量也是兩個表的總數相乘（如圖及附件）

作者: 198188 時間: 2025-10-10 12:12

前輩你好，檢視後，發現有兩點漏了提出，
Layout Dwg 需要加一個篩選條件 “批次”

Part List ...
198188 發表於 2025-10-9 17:30

Layout Dwg 批次問題已經解決。

Part List 補充方面還沒解決
Frame per Dwg 表内欄B "組裝圖號" 含有 WO No 裏面的 "各樣數據" 欄F - 欄K 的英文字母，讀取在Part List 欄G "對應組裝號/加工件號" 相同的"組裝圖號"，及數量相乘。

For i = 2 To UBound(Brr)
If Z.Exists(Brr(i, 2)) Then
If 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
End If
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

複製代碼

作者: 198188 時間: 2025-10-13 10:25

Set Z = CreateObject("Scripting.Dictionary")
xFile = "Data Base.xlsx"
Set xBook = Workbooks(xFile)
a = Sheets("WO No").Range("F2")
b = Sheets("WO No").Range("G2")
c = Sheets("WO No").Range("H2")
d = Sheets("WO No").Range("I2")
e = Sheets("WO No").Range("J2")
f = Sheets("WO No").Range("K2")
G = Sheets("Part List").Range("A1").CurrentRegion.Rows.Count + 1
Brr = Sheets("Frame per Dwg").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Mid(Brr(i, 2), 1, 2) = a Or Mid(Brr(i, 2), 1, 2) = b Or Mid(Brr(i, 2), 1, 2) = c Or Mid(Brr(i, 2), 1, 2) = d Or Mid(Brr(i, 2), 1, 2) = e Or Mid(Brr(i, 2), 1, 2) = f Then
Z(Brr(i, 2)) = Z(Brr(i, 2))
N = N + 1
For j = 1 To 6: Brr(N, j) = Brr(i, j): Next
End If
Next
N = 1
Arr = xBook.Sheets("Part List").[A1].CurrentRegion
For i = 2 To UBound(Arr)
If Z.Exists(Arr(i, 7)) Then
N = N + 1
For j = 1 To 13
Arr(N, j) = Arr(i, j)
Next j
Arr(N, 5) = Arr(N, 5) * Z(Arr(i, 7))
End If
Next
If N > 0 Then Sheets("Part List").Range("A" & G).Resize(N, 13) = Arr

複製代碼

Layout Dwg 批次問題已經解決。

Part List 補充方面還沒解決
Frame per Dwg 表内欄B "組裝圖 ...
198188 發表於 2025-10-10 12:12

Part List 補充方面也解決，但是無法套入相同模組，需要獨立開一個模組。還有複製時，總是會複雜第一欄的名目。

作者: Andy2483 時間: 2025-10-13 11:03

回復 8# 198188

以下方案請試試看

Option Explicit
Sub TEST_2()
Dim Brr, Z, Q, i&, j%, N&, T$, T1$, MyPath$, xFile$, xBook As Workbook, MyBook As Workbook, Re
Application.ScreenUpdating = False
With Sheets("Layout Dwg")
.[A2].Resize(.UsedRange.Rows.Count, 4).ClearContents
End With
With Sheets("Frame per Dwg")
.[A2].Resize(.UsedRange.Rows.Count, 6).ClearContents
End With
With Sheets("Part List")
.[A2].Resize(.UsedRange.Rows.Count, 13).ClearContents
End With
Set MyBook = ThisWorkbook
MyPath = MyBook.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
MyBook.Activate
End If
Set Z = CreateObject("Scripting.Dictionary")
On Error GoTo 0
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").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z.Exists(Brr(i, 2)) Then
   If 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
End If
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
Brr = xBook.Sheets("Frame per Dwg").[A1].CurrentRegion
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, 5) = Brr(N, 5) * Z(Brr(i, 1))
End If
Next
If N > 0 Then Sheets("Frame per Dwg").[A2].Resize(N, 6) = Brr: N = 0 Else MsgBox "Frame per Dwg_Nothing"
Brr = xBook.Sheets("Part List").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z.Exists("|" & Left(Brr(i, 7), 2)) And Z(Brr(i, 7)) > 0 Then
   N = N + 1
   For j = 1 To 13: Brr(N, j) = Brr(i, j): Next
   Brr(N, 3) = Brr(N, 3) * Z(Brr(i, 7))
End If
Next
If N > 0 Then Sheets("Part List").[A2].Resize(N, 13) = Brr Else MsgBox "Part List_Nothing"
12: If Re = True Then xBook.Close 0
End Sub

作者: 198188 時間: 2025-10-13 11:19

回復 198188

以下方案請試試看

Option Explicit
Sub TEST_2()
Dim Brr, Z, Q, i&, j%, N&, T$ ...
Andy2483 發表於 2025-10-13 11:03

感謝前輩指點。
這個方案取消了一個之前的規則， Layout Dwg 裏面的分佈圖在 Frame Per Dwg 找不到的，這些分佈圖（Layout Dwg ) 就在Part List 裏面尋找，並出現在Part List.

作者: 198188 時間: 2025-10-13 11:32

回復 198188

以下方案請試試看

Option Explicit
Sub TEST_2()
Dim Brr, Z, Q, i&, j%, N&, T$ ...
Andy2483 發表於 2025-10-13 11:03

[attach]38114[/attach]
剛剛測試了，導不出數據。
根據WO No 的各樣數據，而Frame per Dwg 裏的組裝圖號有這個數據的英文字母，在Part List 導出數據，

作者: Andy2483 時間: 2025-10-13 13:21

回復 13# 198188

以下方案請試試看

Option Explicit
Sub TEST_2()
Dim Brr, Z, Q, i&, j%, N&, T$, T1$, MyPath$, xFile$, xBook As Workbook, MyBook As Workbook, Re
Application.ScreenUpdating = False
With Sheets("Layout Dwg")
.[A2].Resize(.UsedRange.Rows.Count, 4).ClearContents
End With
With Sheets("Frame per Dwg")
.[A2].Resize(.UsedRange.Rows.Count, 6).ClearContents
End With
With Sheets("Part List")
.[A2].Resize(.UsedRange.Rows.Count, 13).ClearContents
End With
Set MyBook = ThisWorkbook
MyPath = MyBook.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
MyBook.Activate
End If
Set Z = CreateObject("Scripting.Dictionary")
On Error GoTo 0
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").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z.Exists(Brr(i, 2)) Then
   If 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
End If
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
Brr = xBook.Sheets("Frame per Dwg").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z.Exists("|" & Left(Brr(i, 2), 2)) And Z(Brr(i, 1)) > 0 Then
   N = N + 1
   For j = 1 To 6: Brr(N, j) = Brr(i, j): Next
   Brr(N, 5) = Brr(N, 5) * Z(Brr(i, 1))
End If
Next
If N > 0 Then Sheets("Frame per Dwg").[A2].Resize(N, 6) = Brr: N = 0 Else MsgBox "Frame per Dwg_Nothing"
Brr = xBook.Sheets("Part List").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z(Brr(i, 7)) > 0 Then
   N = N + 1
   For j = 1 To 13: Brr(N, j) = Brr(i, j): Next
   Brr(N, 3) = Brr(N, 3) * Z(Brr(i, 7))
End If
Next
If N > 0 Then Sheets("Part List").[A2].Resize(N, 13) = Brr Else MsgBox "Part List_Nothing"
12: If Re = True Then xBook.Close 0
End Sub

作者: Andy2483 時間: 2025-10-13 13:31

感謝前輩指點。
這個方案取消了一個之前的規則， Layout Dwg 裏面的分佈圖在 Frame Per Dwg 找不到的， ...
198188 發表於 2025-10-13 11:19

14#方案是兩表都會找,所以 (FD表分佈圖號) 和 (PL表對應組裝號/加工件號) 如果資料符合邏輯就會重複出現
視需求再調整

作者: 198188 時間: 2025-10-13 14:06

回復 198188

以下方案請試試看

Option Explicit
Sub TEST_2()
Dim Brr, Z, Q, i&, j%, N&, T$ ...
Andy2483 發表於 2025-10-13 13:21

[attach]38115[/attach]
附圖是執行後的結果，Part List 一頁都是空白，沒有資料出來。
兩個規則 1 & 2 都應該有資料，但是沒有導入Part List

作者: Andy2483 時間: 2025-10-13 14:33

回復 16# 198188

範例生產單單號裡沒有 WO-J057-021

作者: 198188 時間: 2025-10-13 14:44

回復 198188

範例生產單單號裡沒有 WO-J057-021
Andy2483 發表於 2025-10-13 14:33

因爲Data Base 資料太多，容量超過1MB 無法上傳，所以我刪除了一些Data Base 内容。
不過按照規則，應該是共通的。
我試過其他的生產單號，Part list 都是空白。

作者: 198188 時間: 2025-10-13 15:05

回復 198188

範例生產單單號裡沒有 WO-J057-021
Andy2483 發表於 2025-10-13 14:33

If Z.Exists("|" & Left(Brr(i, 7), 2)) Or Z(Brr(i, 7)) > 0 Then

複製代碼

我找到問題所在了，這句應該用 "OR "不是用 "AND" , 因爲兩個規則是不能共存的，屬於兩條獨立規則。

作者: Andy2483 時間: 2025-10-14 13:53

回復 8# 198188

以下方案是練習以  Data Base.xlsx 利用輔助欄直接篩選的方案,請前輩參考

1.選取要篩選的項目
2.設按鈕,按鈕執行
[attach]38119[/attach]

Option Explicit
Sub TEST_2()
Dim Brr, Z, S, Q, i&, j%, C, R&, N&, T$, T1$
Application.ScreenUpdating = False
Set Z = CreateObject("Scripting.Dictionary")
Q = Split("Layout Dwg/Frame per Dwg/Part List/WO No", "/")
For Each S In Q
With Sheets(S)
   C = Application.Match("輔助欄", .[1:1], 0)
   If IsError(C) Then
      C = Range(.[A1], .UsedRange).Columns.Count
      C = C + 1
      .Cells(1, C) = "輔助欄"
   End If
   Z(S & "//") = C
   .Activate
   If .AutoFilter Is Nothing Then
      .[A1].Resize(, C).AutoFilter
      With ActiveWindow
         .FreezePanes = False
         .ScrollRow = 1: .ScrollColumn = 1: .SplitRow = 1
         .FreezePanes = True
      End With
      Else
      If .FilterMode = True Then .ShowAllData
      ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1
   End If
End With
Next
R = Selection.Row
T = Cells(R, "B")
T1 = Cells(R, "C")
If T1 = "" Or T = "" Then Exit Sub Else Cells(R, "A").Resize(, 11).Select
For j = 6 To 11
Z("|" & Cells(R, j)) = ""
Next
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 = Sheets("Layout Dwg").[A1].CurrentRegion
For i = 2 To UBound(Brr)
Brr(i - 1, 1) = ""
If Z.Exists(Brr(i, 2)) And Brr(i, 4) = T Then
   Z(Brr(i, 1)) = Z(Brr(i, 1)) + Val(Brr(i, 3))
   Brr(i - 1, 1) = T & "_" & T1
End If
Next
C = Z("Layout Dwg//")
With Sheets("Layout Dwg")
.Cells(2, C).Resize(UBound(Brr) - 1) = Brr
.Cells.AutoFilter Field:=C, Criteria1:="<>"
End With
Brr = Sheets("Frame per Dwg").[A1].CurrentRegion
For i = 2 To UBound(Brr)
Brr(i - 1, 1) = ""
If Z.Exists("|" & Left(Brr(i, 2), 2)) Or Z(Brr(i, 1)) > 0 Then
   S = Brr(i, 5) * Z(Brr(i, 1))
   If S > 0 Then Brr(i - 1, 1) = S
End If
Next
C = Z("Frame per Dwg//")
With Sheets("Frame per Dwg")
.Cells(2, C).Resize(UBound(Brr) - 1) = Brr
.Cells.AutoFilter Field:=C, Criteria1:="<>"
End With
Brr = Sheets("Part List").[A1].CurrentRegion
For i = 2 To UBound(Brr)
Brr(i - 1, 1) = ""
If Z(Brr(i, 7)) > 0 Then
   S = Brr(i, 3) * Z(Brr(i, 7))
   If S > 0 Then Brr(i - 1, 1) = S
End If
Next
C = Z("Part List//")
With Sheets("Part List")
.Cells(2, C).Resize(UBound(Brr) - 1) = Brr
.Cells.AutoFilter Field:=C, Criteria1:="<>"
End With
End Sub

作者: 198188 時間: 2025-10-15 14:01

回復 198188

以下方案是練習以 Data Base.xlsx 利用輔助欄直接篩選的方案,請前輩參考

1.選取 ...
Andy2483 發表於 2025-10-14 13:53

可否説明一下輔助欄的操作原理和規則

作者: Andy2483 時間: 2025-10-15 14:30

回復 21# 198188

WO No表選取 02F-04F後,按鈕執行:
[attach]38123[/attach]

Layout Dwg表會得到符合樓層且符合批次的篩選:
[attach]38124[/attach]

Frame per Dwg表會得到符合條件且數量>0的篩選:
[attach]38125[/attach]

Part List表會得到符合條件且數量>0的篩選:
[attach]38126[/attach]

作者: 198188 時間: 2025-10-15 15:11

[attach]38127[/attach]

回復 198188

WO No表選取 02F-04F後,按鈕執行:

Layout Dwg表會得到符合樓層且符合批次的篩選:
...
Andy2483 發表於 2025-10-15 14:30

我在 "WO NO", "LAYOUT DWG", FRAME PER DWG" , "PART LIST" 裏面加入 “WO-NO" 及執行鍵，運作後，出現 Error

作者: Andy2483 時間: 2025-10-15 15:21

回復 23# 198188

請加入以下紅字行代碼

If .AutoFilter Is Nothing Then
      .[A1].Resize(, C).AutoFilter
      With ActiveWindow
         .FreezePanes = False
         .ScrollRow = 1: .ScrollColumn = 1: .SplitRow = 1
         .FreezePanes = True
      End With
      Else
      .[A1].AutoFilter: .[A1].Resize(, C).AutoFilter
      If .FilterMode = True Then .ShowAllData
      ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1
   End If

作者: 198188 時間: 2025-10-15 15:36

回復 198188

請加入以下紅字行代碼

If .AutoFilter Is Nothing Then
.[A1].Resize ...
Andy2483 發表於 2025-10-15 15:21

可以了，感謝前輩指點。

作者: 198188 時間: 2025-10-20 17:47

回復 198188

請加入以下紅字行代碼

If .AutoFilter Is Nothing Then
.[A1].Resize ...
Andy2483 發表於 2025-10-15 15:21

前輩可否幫我看看這個。

相關規則在 “講解 Rule”一頁詳細講解。

作者: 198188 時間: 2025-10-21 10:29

前輩可否幫我看看這個。

相關規則在 “講解 Rule”一頁詳細講解。
198188 發表於 2025-10-20 17:47

用這個模板，Rule 一頁，我將規則按列模式排列，方便程式設計。

作者: Andy2483 時間: 2025-10-22 14:19

回復 27# 198188

以下方案請試試看

Option Explicit
Sub TEST()
Dim Arr, Brr, Crr(1 To 10000, 1 To 18), A, V, Z, Q, S, i&, j%, R&, C%, y%, K, X%, T$, T1$, T2$, T3$, T4$, Rk$, W, L
Application.ScreenUpdating = False
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([Rule!X1], [Rule!E65536].End(3)(1, -3))
For i = 2 To 6
Z(Brr(i, 3) & "|") = Brr(i, 1)
Next
For i = 2 To UBound(Brr)
For j = 7 To 24
   If Brr(i, j) = "" Then
      If j = 8 Then
         Z("/" & Brr(i, 5) & "/") = Brr(i, 7)
      End If
      Exit For
   End If
   Z("/" & Brr(i, j) & "/") = Brr(i, 5)
   Z("/" & Brr(i, j) & "//") = Brr(i, 6)
Next
Next
Brr = Sheets("講解 Rule").UsedRange
For i = 1 To UBound(Brr)
If Brr(i, 1) Like "規則#*字頭是* 一列的*備注是*複製*" Then
   S = InStr(Brr(i, 1), "字頭是") + 3
   T = Replace(Trim(Mid(Brr(i, 1), S, InStr(Brr(i, 1), " 一列的") - S)), "Hareware", "Hardware")
   Rk = Trim(Mid(Brr(i, 1), InStr(Brr(i, 1), "備注是") + 5, 1))
   S = InStr(Brr(i, 1), "複製 ") + 4
   S = Trim(Mid(Brr(i, 1), S, InStr(Brr(i, 1), " 表格") - 1 - S))
   Z(T & "\" & Rk) = 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
End If
If Brr(i, 1) Like "規則#*字頭是以上藍色字母*組裝圖的出貨情況是*複製*" Then
   Rk = Trim(Mid(Brr(i, 1), InStr(Brr(i, 1), "情況是") + 5, 1))
   S = InStr(Brr(i, 1), "複製 ") + 4
   S = Trim(Mid(Brr(i, 1), S, InStr(Brr(i, 1), " 表格") - 1 - S))
   For y = 1 To 100
      If Brr(i - y, 2) = "" Then Exit For Else T = Brr(i - y, 2)
      Z(Z("/" & T & "/") & "\" & Rk) = 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
End If
Next
Arr = Sheets("Material").UsedRange
For i = 2 To UBound(Arr)
Z(Arr(i, 3) & "/m") = i
Next
Brr = Range(Sheets("Part List").[M1], Sheets("Part List").[A65536].End(3))
For i = 2 To UBound(Brr)
T = Z("/" & Left(Brr(i, 1), 2) & "/")
T4 = Z("/" & Left(Brr(i, 1), 2) & "//")
Rk = Brr(i, 7)
T2 = Z(T & "\" & Rk)
T3 = T & "-" & Z(Rk & "|")
If Len(T3) > 31 Then '工作表名>31字(改以中文表示)
   T3 = T4 & "-" & Z(Rk & "|")
End If
Z("|" & T3) = T2
A = Z("/" & T3)
R = Z("r/" & T3)
If Not IsArray(A) Then
   A = Crr
End If
If T2 = "Bom" Then
   R = R + 1
   A(R, 1) = R
   A(R, 2) = Brr(i, 1)
   A(R, 3) = Brr(i, 12)
   If A(R, 3) <> "" Then
      A(R, 4) = Arr(Z(A(R, 3) & "/m"), 5)
      A(R, 5) = Arr(Z(A(R, 3) & "/m"), 6)
      A(R, 6) = Arr(Z(A(R, 3) & "/m"), 7)
      A(R, 8) = Arr(Z(A(R, 3) & "/m"), 11)
      A(R, 9) = Arr(Z(A(R, 3) & "/m"), 10)
      A(R, 13) = Arr(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)
   GoTo i01
End If
If T2 = "Gasket" Then
   R = R + 1
   A(R, 1) = R
   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) <> "" Then
      A(R, 4) = Arr(Z(A(R, 3) & "/m"), 5)
      A(R, 5) = Arr(Z(A(R, 3) & "/m"), 6)
      A(R, 8) = Arr(Z(A(R, 3) & "/m"), 8)
   End If
   GoTo i01
End If
If T2 = "Structural" Then
   R = R + 1
   A(R, 1) = R
   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)
   GoTo i01
End If
If T2 = "DN Material" Then '
   R = R + 1
   A(R, 1) = R
   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) <> "" Then
      A(R, 5) = Arr(Z(A(R, 3) & "/m"), 11)
      A(R, 6) = Arr(Z(A(R, 3) & "/m"), 8)
      A(R, 6) = A(R, 5) * A(R, 7)
   End If
   A(R, 9) = Brr(i, 7)
   GoTo i01
End If
If T2 = "Fabrication Extrusion" Then
   R = R + 1
   A(R, 1) = R
   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 If
i01: Z("/" & T3) = A
Z("r/" & T3) = R
Next
Brr = Range(Sheets("Frame per Dwg").[M1], Sheets("Frame per Dwg").[A65536].End(3))
For i = 2 To UBound(Brr)
T = Z("/" & Left(Brr(i, 2), 2) & "/")
T4 = Z("/" & T & "/")
Rk = Brr(i, 6)
T2 = Z(T & "\" & Rk)
T3 = T4 & "-" & Z(Rk & "|")
Z("|" & T3) = T2
A = Z("/" & T3)
R = Z("r/" & T3)
If Not IsArray(A) Then
   A = Crr
End If
If T2 = "Finish" Then
   R = R + 1
   A(R, 1) = R
   A(R, 2) = Brr(i, 2)
   A(R, 3) = Brr(i, 3)
   A(R, 4) = Brr(i, 4)
   A(R, 5) = Brr(i, 5)
   A(R, 7) = Brr(i, 6)
End If
Z("/" & T3) = A
Z("r/" & T3) = R
Next
Workbooks.Add
Q = ActiveWorkbook.Name
For Each K In Z.Keys
If IsArray(Z(K)) And Z("r" & K) > 0 Then
   T = Mid(K, 2)
   ThisWorkbook.Sheets(Z("|" & T)).Copy Before:=Workbooks(Q).Sheets(1)
   ActiveSheet.Name = T
   With Cells(Z(Z("|" & T) & "/UR"), 1).Resize(Z("r" & K), Z(Z("|" & T) & "/UC"))
      .Value = Z(K)
      .Borders.LineStyle = xlContinuous
   End With
End If
Next
End Sub

作者: 198188 時間: 2025-10-22 16:25

本帖最後由 198188 於 2025-10-22 16:27 編輯

回復 198188

以下方案請試試看

Option Explicit
Sub TEST()
Dim Arr, Brr, Crr(1 To 10000 ...
Andy2483 發表於 2025-10-22 14:19

因爲程式中有中文，無法運行，我更新了一下規則，規則用列表模式顯示，用 “ Symbol" 來識別備注符號，用 "Code" 來識別頭兩個字頭。這樣即使將來要增加或減少符號及編號都不影響程式。

1) 根據Rule的規則, 當 “Part List” 欄G ”備注” 的符號及欄A 的字頭跟 “Rule” 的Symbol 欄 & Code 欄相同，根據 Rule欄A 的Form名稱複雜一個新模板，命名為欄I的English Product + Symbol 的對應名稱並去除 “-“ 和後面的中文字
舉例
Part List 裏面是 “F0” 字頭 & “Y” 備注, 複製Bom 模板，命名 “Screw-Deliver to Site”
Part List 裏面是 “IG” 字頭 & “-” 備注, 複製Gasket 模板，命名 “Gasket-Deliver to Factory”
Part List 裏面是 “E1” 字頭 & “Y” 備注, 複製DN Material 模板，命名 “Extrusion-Delivery Notes For Material Parts”

2) 根據Rule的規則, 當 “Frame per Dwg” 欄F ”備注” 的符號及欄B的字頭跟 “Rule” 的Symbol 欄 & Code 欄相同，根據 Rule欄A 的Form名稱複雜一個新模板，命名為欄I的English Product + Symbol 的對應名稱並去除 “-“ 和後面的中文字
舉例
Frame per Dwg 裏面是 “DF” 字頭 & “T” 備注, 複製Finish 模板，命名 “Door Frame- Finish Part Order On-Hold”
Frame per Dwg 裏面是 “WS” 字頭 & “T” 備注, 複製Finish 模板，命名 “Window Sash - Finish Part Order On-Hold”
Frame per Dwg 裏面是 “DF” 字頭 & “W” 備注, 複製Finish 模板，命名 “Door Frame - Finish Part Order”

Bom模板填寫規則
Range (“A4”) = 欄G 的英文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “ Screw – 螺絲”; 讀取Panel 的資料，備注是 - ，顯示 ”Panel – 鈑金”)
Range (“A5”) = 欄 H 的中文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “Deliver to Site -工地用”; 讀取Panel 的資料，備注是 - ，顯示 ”Deliver to Factory - 廠房用”)
尺寸 = Part List 欄 L 長度 "x" 欄 M 寬度 (舉例 2211.1 x 717.9）
數量 = Part List 欄  C 數量
備註 =  Part List 欄  G 備註量
供應商編號 = Material 欄 C 供應商編號
英文描述 = Material 欄 E 英文描述(對客戶)
中文描述 = Material 欄 F 中文描述(對供應商)
材質, 標準及等級 = Material 欄 G 材質
單重 = Material 欄 K 單重
顔色/表面處理 = Material 欄 J 顔色/表面處理
單位 = Material 欄 H 英文單位

Gasket模板填寫規則
Range (“D6”) = 欄G 的英文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “ Screw – 螺絲”; 讀取Panel 的資料，備注是 - ，顯示 ”Panel – 鈑金”)
Range (“D7”) = 欄 H 的中文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “Deliver to Site -工地用”; 讀取Panel 的資料，備注是 - ，顯示 ”Deliver to Factory - 廠房用”)
序號= 1，2，3順序
編號 = Part List 欄 A 加工件編號
總數量 = Part List 欄  C 數量
寬度 = Part List 欄 E 寬度
高度 = Part List 欄 F 高度
備註 =  Part List 欄  G 備註量
供應商編碼 = Material 欄 C 供應商模號
英文描述 = Material 欄 E 英文描述(對客戶)
中文描述 = Material 欄 F 中文描述(對供應商)
單位 = Material 欄 H 英文單位

Structural 模板填寫規則
Range (“C3”) = 欄G 的英文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “ Screw – 螺絲”; 讀取Panel 的資料，備注是 - ，顯示 ”Panel – 鈑金”)
Range (“C4”) = 欄 H 的中文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “Deliver to Site -工地用”; 讀取Panel 的資料，備注是 - ，顯示 ”Deliver to Factory - 廠房用”)
序號= 1，2，3順序
編號 = Part List 欄 A 加工件編號
材料描述 =  Part List 欄 B 描述
總長度 = Part List 欄 C 數量
截面積 = Part List 欄 B 描述的長度相乘舉例描述是"19.8mmx8mm DC983 STRUCTURAL SILICONE-BLACK"  截面積計算為 19.8*8=158.4
總容量 = 欄E 總長度 * 欄F 截面積 / 1000 (小數點進1, 舉例 12.1 =13；14.3 = 15； 0.8 = 1)

DN Material 模板填寫規則
Range (“A3”) = 欄G 的英文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “ Screw – 螺絲”; 讀取Panel 的資料，備注是 - ，顯示 ”Panel – 鈑金”)
Range (“A4”) = 欄 H 的中文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “Deliver to Site -工地用”; 讀取Panel 的資料，備注是 - ，顯示 ”Deliver to Factory - 廠房用”)
序號= 1，2，3順序
編碼 = Part List 欄 A 加工件編號
供應商編號 = Part List 欄 K 供應商編號
寬度 = Part List 欄 E 寬度
總數量 = Part List 欄  C 數量
單重 = 用供應商編號讀取 Material 欄 K 單重
單位 = 用供應商編號讀取 Material 欄 H 英文單位
總重量 = 欄 E 單重 * 欄G 總數量
備註 =  Part List 欄  G 備註量

Fabrication Extrusion模板填寫規則
Range (“A3”) = 欄G 的英文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “ Screw – 螺絲”; 讀取Panel 的資料，備注是 - ，顯示 ”Panel – 鈑金”)
Range (“A4”) = 欄 H 的中文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “Deliver to Site -工地用”; 讀取Panel 的資料，備注是 - ，顯示 ”Deliver to Factory - 廠房用”)
序號= 1，2，3順序
加工件編號 = Part List 欄 A 加工件編號
模號 = Part List 欄 K 供應商編號
成色編號  = Part List 欄 J 成色編號
長度 =  Part List 欄 D 長度
總數量 = Part List 欄  C 數量
參考圖號 = Part List 欄 A 加工件編號去除第二個 “-” 後面的字（如有）
舉例加工件編號 E1106-600 參考圖號 E1106-600; 加工件編號 E1106-600-01 參考圖號 E1106-600; 加工件編號 E1106-600-11 參考圖號 E1106-600
備註 =  Part List 欄  G 備註量

Finish 模板填寫規則
Range (“A3”) = 欄G 的英文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “ Screw – 螺絲”; 讀取Panel 的資料，備注是 - ，顯示 ”Panel – 鈑金”)
Range (“A4”) = 欄 H 的中文名稱 + 備注相關的B 列名稱 (舉例讀取Screw 的資料，備注是Y, 顯示 “Deliver to Site -工地用”; 讀取Panel 的資料，備注是 - ，顯示 ”Deliver to Factory - 廠房用”)
序號= 1，2，3順序
單元件編號 = Frame per Dwg 欄 B 組裝圖編號 (相應頭兩個字母）
寬度 = Frame per Dwg 欄 C 組裝圖寬度
高度 = Frame per Dwg 欄 D 組裝圖高度
總數量 = Frame per Dwg 欄 E 組裝圖在分佈圖上的數量
備註 = Frame per Dwg 欄 F 組裝圖的出貨情況

作者: 198188 時間: 2025-10-22 16:35

因爲程式中有中文，無法運行，我更新了一下規則，規則用列表模式顯示，用 “ Symbol" 來識別備注 ...
198188 發表於 2025-10-22 16:25

另外制表完成後，可否將生成的制表，打印 PDF save 在該 Excel 的位置？

作者: Andy2483 時間: 2025-10-22 16:44

回復 29# 198188

請將規則文字敘述表單化後上傳新範例 ,如下圖

[attach]38143[/attach]

作者: 198188 時間: 2025-10-23 08:12

本帖最後由 198188 於 2025-10-23 08:26 編輯

回復 198188

請將規則文字敘述表單化後上傳新範例 ,如下圖
Andy2483 發表於 2025-10-22 16:44

[attach]38147[/attach]

由於中文會有亂碼，所以我上載的範例 Result 用英文敘述，另外圖片用中文敘述。附件規則是中文描述規則。

Rule 欄 A "複製表格 Copy Form" 藍色部分是指示複雜哪個模板的表格
Rule 欄 B - H "備注符號 Remark " 黃色部分是對應 Part List 欄 G "備注" & Frame per Dwg 欄 F "組裝圖的出貨情況" 的辨認
Rule 欄 K - AB " 關鍵字Key Word" 綠色部分是對應 Part List 欄 A "加工件編號" & Frame per Dwg 欄 B "組裝圖編號" 的頭兩個字的辨認
當 Rule 欄 B - H "備注符號 Remark " & Rule 欄 K - AB " 關鍵字Key Word" 兩個都符合條件的根據Rule 欄 A "複製表格 Copy Form" 來生產一個新的表格，然後按照規則來填入資料。
最後把所有新生成的表格，打印成PDF 儲存在當下的桌面 / 該Excel 的位置。

作者: Andy2483 時間: 2025-10-23 08:43

回復 32# 198188

工作表名稱只能有31個字元,若超過如何處理?

作者: 198188 時間: 2025-10-23 11:24

回復 198188

工作表名稱只能有31個字元,若超過如何處理?
Andy2483 發表於 2025-10-23 08:43

如果只有1個 Key Word 的直接用 Key Word 命名,
如果出現超過一個 key word 的直接用English Product命名。

舉例
Hardware = HW
Screw = Screw
Weather Sealant = Weather Sealant
Flush Slab Edge Cover Frame = FF
Door Frame = DF
Casting = Casting
Structural Sealant = Structural Sealant
Gasket = Gasket
Thermal Rock = TR

另外Remark
直接用符號命名。
符號 - 用 -
符號 Y 用Y
符號 O 用 O
符號 T 用 T
符號 W 用 W

作者: Andy2483 時間: 2025-10-23 11:57

回復 34# 198188

以下請先試試看

Option Explicit
Sub TEST()
Dim Arr, Brr, Crr(1 To 10000, 1 To 18), A, V, Z, Q, S, i&, j%, R&, C%, y%, K, X%, T$, T1$, T2$, T3$, T4$, T5$, Rk$, W, L
Application.ScreenUpdating = False
Set Z = CreateObject("Scripting.Dictionary")
Brr = [Rule!A1].CurrentRegion
For j = 2 To 8
T = Trim(Mid(Brr(2, j), 1, Len(Brr(2, j)) * 2 - LenB(StrConv(Brr(2, j), vbFromUnicode)) - 2))
For i = 3 To UBound(Brr)
   If Brr(i, j) <> "" Then Z(Brr(i, j) & "|") = T: Exit For
Next
Next
For i = 3 To UBound(Brr)
For j = 11 To 28
   If Brr(i, j) = "" Then
      If j = 12 Then
         Z("/" & Brr(i, 9) & "/") = Brr(i, 11)
      End If
      Exit For
   End If
   Z("/" & Brr(i, j) & "/") = Brr(i, 9)
   Z("/" & Brr(i, j) & "//") = Brr(i, 10)
Next
Next
For i = 3 To UBound(Brr)
   T = Brr(i, 9)
   Rk = ""
   For j = 2 To 8
      Rk = Rk & Brr(i, j)
   Next
   S = Brr(i, 1)
   Z(T & "\" & Rk) = 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
Arr = Sheets("Material").UsedRange
For i = 2 To UBound(Arr)
Z(Arr(i, 3) & "/m") = i
Next
Brr = Range(Sheets("Part List").[M1], Sheets("Part List").[A65536].End(3))
For i = 2 To UBound(Brr)
T5 = Left(Brr(i, 1), 2)
T = Z("/" & T5 & "/")
T4 = Z("/" & Left(Brr(i, 1), 2) & "//")
Rk = Brr(i, 7)
T2 = Z(T & "\" & Rk)
T3 = T & "-" & Z(Rk & "|")
If Len(T3) > 31 Then
   T3 = T4 & "-" & Z(Rk & "|")
   If Len(T3) > 31 Then
      T3 = T5 & "-" & Rk
   End If
End If
Z("|" & T3) = T2
A = Z("/" & T3)
R = Z("r/" & T3)
If Not IsArray(A) Then
   A = Crr
End If
If T2 = "Bom" Then
   R = R + 1
   A(R, 1) = R
   A(R, 2) = Brr(i, 1)
   A(R, 3) = Brr(i, 12)
   If A(R, 3) <> "" Then
      A(R, 4) = Arr(Z(A(R, 3) & "/m"), 5)
      A(R, 5) = Arr(Z(A(R, 3) & "/m"), 6)
      A(R, 6) = Arr(Z(A(R, 3) & "/m"), 7)
      A(R, 8) = Arr(Z(A(R, 3) & "/m"), 11)
      A(R, 9) = Arr(Z(A(R, 3) & "/m"), 10)
      A(R, 13) = Arr(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)
   GoTo i01
End If
If T2 = "Gasket" Then
   R = R + 1
   A(R, 1) = R
   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) <> "" Then
      A(R, 4) = Arr(Z(A(R, 3) & "/m"), 5)
      A(R, 5) = Arr(Z(A(R, 3) & "/m"), 6)
      A(R, 8) = Arr(Z(A(R, 3) & "/m"), 8)
   End If
   GoTo i01
End If
If T2 = "Structural" Then
   R = R + 1
   A(R, 1) = R
   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)
   GoTo i01
End If
If T2 = "DN Material" Then '
   R = R + 1
   A(R, 1) = R
   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) <> "" Then
      A(R, 5) = Arr(Z(A(R, 3) & "/m"), 11)
      A(R, 6) = Arr(Z(A(R, 3) & "/m"), 8)
      A(R, 6) = A(R, 5) * A(R, 7)
   End If
   A(R, 9) = Brr(i, 7)
   GoTo i01
End If
If T2 = "Fabrication Extrusion" Then
   R = R + 1
   A(R, 1) = R
   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 If
i01: Z("/" & T3) = A
Z("r/" & T3) = R
Next
Brr = Range(Sheets("Frame per Dwg").[M1], Sheets("Frame per Dwg").[A65536].End(3))
For i = 2 To UBound(Brr)
T = Z("/" & Left(Brr(i, 2), 2) & "/")
T4 = Z("/" & T & "/")
Rk = Brr(i, 6)
T2 = Z(T & "\" & Rk)
T3 = T4 & "-" & Z(Rk & "|")
Z("|" & T3) = T2
A = Z("/" & T3)
R = Z("r/" & T3)
If Not IsArray(A) Then
   A = Crr
End If
If T2 = "Finish" Then
   R = R + 1
   A(R, 1) = R
   A(R, 2) = Brr(i, 2)
   A(R, 3) = Brr(i, 3)
   A(R, 4) = Brr(i, 4)
   A(R, 5) = Brr(i, 5)
   A(R, 7) = Brr(i, 6)
End If
Z("/" & T3) = A
Z("r/" & T3) = R
Next
Workbooks.Add
Q = ActiveWorkbook.Name
For Each K In Z.Keys
If IsArray(Z(K)) And Z("r" & K) > 0 Then
   T = Mid(K, 2)
   ThisWorkbook.Sheets(Z("|" & T)).Copy Before:=Workbooks(Q).Sheets(1)
   ActiveSheet.Name = T
   With Cells(Z(Z("|" & T) & "/UR"), 1).Resize(Z("r" & K), Z(Z("|" & T) & "/UC"))
      .Value = Z(K)
      .Borders.LineStyle = xlContinuous
   End With
End If
Next
End Sub

作者: 198188 時間: 2025-10-23 13:10

回復 198188

以下請先試試看

Option Explicit
Sub TEST()
Dim Arr, Brr, Crr(1 To 10000, ...
Andy2483 發表於 2025-10-23 11:57

[attach]38149[/attach]
執行後，出現這個錯誤。

作者: Andy2483 時間: 2025-10-23 13:59

回復 36# 198188

可能原因:Material表資料不完整
Part List表L(供應商編號) 在 Material表C欄找不到相應的(供應商編號)

作者: 198188 時間: 2025-10-23 14:21

回復 198188

可能原因:Material表資料不完整
Part List表L(供應商編號) 在 Material表C欄找不 ...
Andy2483 發表於 2025-10-23 13:59

那能不能加一句，如果讀取Material 時找不到的，直接空白？

作者: Andy2483 時間: 2025-10-23 14:38

本帖最後由 Andy2483 於 2025-10-23 14:44 編輯

回復 38# 198188

裡面有3行: If A(R, 3) <> "" Then
都置換成: If A(R, 3) <> "" And Z.Exists(A(R, 3) & "/m") Then

作者: 198188 時間: 2025-10-23 14:53

[attach]38150[/attach]

回復  198188

裡面有3行: If A(R, 3)  "" Then
都置換成: If A(R, 3)  "" And Z.Exists( ...
Andy2483 發表於 2025-10-23 14:38

改完之後，運行程式，整個Excel 一直沒有回應。

作者: 198188 時間: 2025-10-23 15:05

[attach]38151[/attach]

改完之後，運行程式，整個Excel 一直沒有回應。
198188 發表於 2025-10-23 14:53

運行大概半小時後，出現這個錯誤。

作者: Andy2483 時間: 2025-10-23 15:06

回復 40# 198188

我測試 Part List表2000列需要60秒

作者: Andy2483 時間: 2025-10-23 15:19

回復 41# 198188

沒有實際大量資料範例做測試,只能建議自行漸進增加資料量做測試

作者: Andy2483 時間: 2025-10-23 16:06

回復 40# 198188

陣列在字典呼叫出來與該陣列放回字典裡需要時間,資料量少還可以,但大資料量如果要縮短時間:
理論上是可以輔助欄取 A欄加工件編號前2碼與 G欄備注做2層排序,並修改迴圈的運行方式,應該可以縮短時間
後學再撥空研究看看

作者: 198188 時間: 2025-10-23 16:31

回復 198188

沒有實際大量資料範例做測試,只能建議自行漸進增加資料量做測試
Andy2483 發表於 2025-10-23 15:19

[attach]38159[/attach]

由於檔案過大，無法上載，我拆分了 7 個 Excel
Result 23 Oct 是我用來測試的模板和程式,
Data Base 1 是除了 Part List 這頁資料的 Data Base
Data Base 裏面的 Part List 共有 45135 個資料，我分別用 5 個Excel 承載。從1-10000，10001-20000，20001-30000， 30001-40000， 40001-45135

其中我發現一個問題，就是運行之前的 Data 程式是，Part List 的數量全部是 0，而且資料不對。
規則是
日期批次次序樓層生產單號項目内容各樣數據
22-Dec-23 A 02F-08F WO-J057-022 02F-08F窗玉 WS - - - - -

第一 Layout Dwg 裏面分佈圖號在 Frame per Dwg 沒有的分佈圖，要篩選在Part List
第二根據 Frame Per Dwg 裏面的組裝圖號，在Part List 篩選出來, (只顯示 WO No 各樣數據有的相關字母，以上列是WS字頭的才出現）
請參考附件Data 程式規則錯誤。

不知是否因爲這個問題，導致Form 這個程式運行。

作者: Andy2483 時間: 2025-10-23 16:38

回復 45# 198188

太燒腦了,放假後再撥空下載試試

作者: 198188 時間: 2025-10-23 16:44

回復 198188

太燒腦了,放假後再撥空下載試試
Andy2483 發表於 2025-10-23 16:38

有勞前輩了。

作者: 198188 時間: 2025-10-27 10:54

本帖最後由 198188 於 2025-10-27 11:07 編輯

Sub Data()
Dim Brr, Z, Q, i&, j%, N&, T$, T1$, MyPath$, xFile$, xBook As Workbook, MyBook As Workbook, Re
Sheets("WO No").Range("A2").EntireRow.Delete
Sheets("Layout Dwg").Range("A2:D66500").ClearContents
Sheets("Frame per Dwg").Range("A2:F66500").ClearContents
Sheets("Part List").Range("A2:M66500").ClearContents
Set Z = CreateObject("Scripting.Dictionary")
Set MyBook = ThisWorkbook
MyPath = MyBook.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
MyBook.Activate
End If
On Error GoTo 0
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)
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").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z.Exists(Brr(i, 2)) Then
If 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
End If
End If
Next
If N > 0 Then Sheets("Layout Dwg").[A2].Resize(N, 4) = Brr: N = 0 Else MsgBox "Nothing under the floor"
Brr = xBook.Sheets("Frame per Dwg").[A1].CurrentRegion
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, 5) = Brr(N, 5) * Z(Brr(i, 1))
End If
Next
If N > 0 Then Sheets("Frame per Dwg").[A2].Resize(N, 6) = Brr: N = 0
'===========================================================================
Brr = xBook.Sheets("Part List").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z(Brr(i, 7)) > 0 Then
N = N + 1
For j = 1 To 13: Brr(N, j) = Brr(i, j): Next
Brr(N, 3) = Brr(N, 3) * Z(Brr(i, 7))
End If
Next
If N > 0 Then Sheets("Part List").[A2].Resize(N, 13) = Brr
'==================================================================
A = Sheets("WO No").Range("F2")
b = Sheets("WO No").Range("G2")
C = Sheets("WO No").Range("H2")
d = Sheets("WO No").Range("I2")
e = Sheets("WO No").Range("J2")
f = Sheets("WO No").Range("K2")
G = Sheets("Part List").Range("A1").CurrentRegion.Rows.Count + 1
Brr = Sheets("Frame per Dwg").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Mid(Brr(i, 2), 1, 2) = A Or Mid(Brr(i, 2), 1, 2) = b Or Mid(Brr(i, 2), 1, 2) = C Or Mid(Brr(i, 2), 1, 2) = d Or Mid(Brr(i, 2), 1, 2) = e Or Mid(Brr(i, 2), 1, 2) = f Then
Z(Brr(i, 2)) = Z(Brr(i, 2))
N = N + 1
For j = 1 To 6: Brr(N, j) = Brr(i, j): Next
End If
Next
N = 1
Arr = xBook.Sheets("Part List").[A1].CurrentRegion
For i = 2 To UBound(Arr)
If Z.Exists(Arr(i, 8)) Then
N = N + 1
For j = 1 To 13
Arr(N, j) = Arr(i, j)
Next j
Arr(N, 5) = Arr(N, 5) * Z(Arr(i, 7))
End If
Next
If N > 0 Then Sheets("Part List").Range("A" & G).Resize(N, 13) = Arr
Sheets("Part List").Select
Rows(G).Select
Selection.Delete Shift:=xlUp
If Re = True Then xBook.Close 0
End Sub

複製代碼

回復 198188

太燒腦了,放假後再撥空下載試試
Andy2483 發表於 2025-10-23 16:38

前輩，Part List 部分，我解決了一部分，但是出來的資料，還是不完整。

製表部分，是根據之前導出的 “Part List ”内的資料，來製表。
我運作後，發現是卡在打開新的Excel 新增 Sheet 那裏卡住，不懂得新增。

作者: 198188 時間: 2025-10-27 11:31

前輩，Part List 部分，我解決了一部分，但是出來的資料，還是不完整。

製表部分，是根據之前導出的 ...
198188 發表於 2025-10-27 10:54

If Z.Exists(Brr(i, 2)) Then
這句應該如何修改，我想找尋包含 BC132 (Brr(i,2)) 的字母的數據？
BC132
BC132a
BC132b
BC132c

作者: Andy2483 時間: 2025-10-27 15:31

本帖最後由 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

作者: 198188 時間: 2025-10-27 16:05

回復 198188
[attach]38173[/attach]

以下方案請試試看:

Option Explicit
Dim A, Z, R&, W, L, i&, Brr, Mrr, Q, Dr ...
Andy2483 發表於 2025-10-27 15:31

這個是製表部分嗎？
我前面Part List 抽取資料部分，能否幫我看看，如附圖規則。因爲這裏卡住，所以會影響制表的結果。

作者: Andy2483 時間: 2025-10-27 16:29

回復 51# 198188

"前面Part List 抽取資料部分" 是哪一樓層方案不符合需求?

作者: 198188 時間: 2025-10-27 17:43

回復 198188

以下方案請試試看

Option Explicit
Sub TEST_2()
Dim Brr, Z, Q, i&, j%, N&, T$ ...
Andy2483 發表於 2025-10-13 13:21

Brr = xBook.Sheets("Part List").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z(Brr(i, 7)) > 0 Then
   N = N + 1
   For j = 1 To 13: Brr(N, j) = Brr(i, j): Next
   Brr(N, 3) = Brr(N, 3) * Z(Brr(i, 7))
End If
Next
If N > 0 Then Sheets("Part List").[A2].Resize(N, 13) = Brr Else MsgBox "Part List_Nothing"

[attach]38174[/attach]

前輩是這個部分的資料不正確，應該以圖片的規則篩選PART LIST資料。

作者: Andy2483 時間: 2025-10-27 19:36

回復 53# 198188
需要以#13執行#8範例的結果如何錯，正確值又該如何呈現？說明正確與錯誤差異

作者: 198188 時間: 2025-10-28 09:30

回復 198188
需要以#13執行#8範例的結果如何錯，正確又該如何呈現？說明正確與錯誤差異
Andy2483 發表於 2025-10-27 19:36

[attach]38175[/attach]

規則有3個：
1) Layout Dwg 裏面圖號沒有在 Frame per Dwg 出現的，就顯示在 Part List  = 這個ok 了

2) Frame per Dwg 的欄B 組裝圖號包含 WO No  欄F - 欄K 的各樣數據字母，就顯示在 Part List = 這個ok 了

3) 圖片Layout Dwg 有下面5個圖號，在Frame per Dwg 沒有出現，所以需要在 Part List 裏顯示出來。不過在Part List 裏面的圖號，有可能最後加一個小寫的英文字母，a/b/c/d.... 所以需要再加一個Rule, 如果Part List 最後一個字母是小寫，那麽 Part List 的圖號包含Laybout Dwg 的圖號，就要顯示出來。如圖片。 = 這個沒做到

Layout Dwg裏面有
MWB03
MWB04
MWB05
MWB06
MWB07

Part List  裏面有
MWB03a
MWB04b
MWB05c
MWB06e
MWB07b

作者: 198188 時間: 2025-10-28 10:11

規則有3個：
1) Layout Dwg 裏面圖號沒有在 Frame per Dwg 出現的，就顯示在 Part List = 這個o ...
198188 發表於 2025-10-28 09:30

上個貼因爲修改超時，所以改不了，請以這個爲準。

[attach]38179[/attach][attach]38180[/attach]

規則有3個：
1) Layout Dwg 裏面圖號沒有在 Frame per Dwg 出現的，就顯示在 Part List  = 這個ok 了, 不過需要加上規則3

2) Frame per Dwg 的欄B 組裝圖號包含 WO No  欄F - 欄K 的各樣數據字母，就顯示在 Part List = 這個ok 了，不過多了下面這些不應該出現的圖號
批次次序樓層生產單號                   各樣數據
A             02F-08F WO-J057-022          WS

在Layout Dwg 沒有下面這些圖號，但是運行後面，Part List 出現這些圖號
WS001, WS003, WS004, WS100,  WS101, WS102, WS600, WS601, WS602, WS603

3) 圖片Layout Dwg 有下面5個圖號，在Frame per Dwg 沒有出現，所以需要在 Part List 裏顯示出來。不過在Part List 裏面的圖號，有可能最後加一個小寫的英文字母，a/b/c/d.... 所以需要再加一個Rule, 如果Part List 最後一個字母是小寫，那麽 Part List 的圖號包含Laybout Dwg 的圖號，就要顯示出來。如圖片。 = 這個沒做到

Layout Dwg裏面有
MWB02
MWB03
MWB04
MWB05
MWB06
MWB07


Part List  裏面有
MWB02b
MWB03b
MWB04b
MWB05b
MWB06b
MWB07b

作者: Andy2483 時間: 2025-10-28 10:38

回復 55# 198188

請將以下
For i = 2 To UBound(Brr)
If Z(Brr(i, 7)) > 0 Then
   N = N + 1
   For j = 1 To 13: Brr(N, j) = Brr(i, j): Next
   Brr(N, 3) = Brr(N, 3) * Z(Brr(i, 7))
End If
Next

改為
For i = 2 To UBound(Brr)
If Brr(i, 7) Like "*[a-z]" Then Q = Left(Brr(i, 7), Len(Brr(i, 7)) - 1) Else Q = ""
If Z(Brr(i, 7)) > 0 Or Z(Q) > 0 Then
   N = N + 1
   For j = 1 To 13: Brr(N, j) = Brr(i, j): Next
   Brr(N, 3) = Brr(N, 3) * Z(Brr(i, 7))
End If
Next

試試看

作者: Andy2483 時間: 2025-10-28 10:48

回復 55# 198188

Brr(N, 3) = Brr(N, 3) * Z(Brr(i, 7))

這行也要改成以下,數量才會是0

Brr(N, 3) = Brr(N, 3) * (Z(Brr(i, 7)) + Z(Q))

作者: 198188 時間: 2025-10-28 11:04

Sub TEST_2()
Dim Brr, Z, Q, i&, j%, N&, T$, T1$, MyPath$, xFile$, xBook As Workbook, MyBook As Workbook, Re
Application.ScreenUpdating = False
With Sheets("Layout Dwg")
.[A2].Resize(.UsedRange.Rows.Count, 4).ClearContents
End With
With Sheets("Frame per Dwg")
.[A2].Resize(.UsedRange.Rows.Count, 6).ClearContents
End With
With Sheets("Part List")
.[A2].Resize(.UsedRange.Rows.Count, 13).ClearContents
End With
Set MyBook = ThisWorkbook
MyPath = MyBook.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
MyBook.Activate
End If
Set Z = CreateObject("Scripting.Dictionary")
On Error GoTo 0
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").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z.Exists(Brr(i, 2)) Then
If 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
End If
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
Brr = xBook.Sheets("Frame per Dwg").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z.Exists("|" & Left(Brr(i, 2), 2)) And Z(Brr(i, 1)) > 0 Then
N = N + 1
For j = 1 To 6: Brr(N, j) = Brr(i, j): Next
Brr(N, 5) = Brr(N, 5) * Z(Brr(i, 1))
End If
Next
If N > 0 Then Sheets("Frame per Dwg").[A2].Resize(N, 6) = Brr: N = 0 Else MsgBox "Frame per Dwg_Nothing"
Brr = xBook.Sheets("Part List").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Brr(i, 7) Like "*[a-z]" Then Q = Left(Brr(i, 7), Len(Brr(i, 7)) - 1) Else Q = ""
If Z(Brr(i, 7)) > 0 Or Z(Q) > 0 Then
N = N + 1
For j = 1 To 13: Brr(N, j) = Brr(i, j): Next
Brr(N, 3) = Brr(N, 3) * (Z(Brr(i, 7)) + Z(Q))
End If
Next
If N > 0 Then Sheets("Part List").[A2].Resize(N, 13) = Brr Else MsgBox "Part List_Nothing"
12: If Re = True Then xBook.Close 0
End Sub

複製代碼

回復 198188

Brr(N, 3) = Brr(N, 3) * Z(Brr(i, 7))

這行也要改成以下,數量才會是0

Br ...
Andy2483 發表於 2025-10-28 10:48

這個不對，改了這個 Frame per Dwg 變成了只有 WS 的組裝圖號，其他的不出現。

我剛剛說的是針對 Part List 的内容， Frame per Dwg 之前的内容是正確的。

Frame per Dwg 内容規則：
在 Frame per Dwg 導出與 Layout Dwg 相同的分佈圖號，Layout Dwg相同圖號數量相加然後跟 Frame per Dwg 數量相乘

Part List 内容規則：
1） Layout Dwg 分佈圖號在 Frame per Dwg 裏面沒有出現的，要在 Part List 出現，數量相乘
2）在上面規則下，附加多一個條件，如果 Part List 分佈圖號最後一個字母是小寫英文字母，那麽 Part List 分佈圖號包含 Layout Dwg 分佈圖號的也顯示出來。
3）Frame per Dwg 的組裝圖欄B 含有 WO No 的欄 F - K 各樣數據字母，要在 Part List 出現數量相乘

作者: Andy2483 時間: 2025-10-28 11:26

回復 59# 198188

Layout Dwg 分佈圖號在 Frame per Dwg 裏面沒有出現的，要在 Part List 出現，數量相乘
這兩表欄位不同! 該如何在 Part List 出現，數量相乘

作者: Andy2483 時間: 2025-10-28 11:41

回復 59# 198188

Layout Dwg 分佈圖號在 Frame per Dwg 裏面沒有出現的，要在 Part List 出現，數量相乘
還是 ayout Dwg 分佈圖號在 Frame per Dwg 出現過的,在 Part List 不能重複篩出來

作者: 198188 時間: 2025-10-28 11:47

回復 198188

Layout Dwg 分佈圖號在 Frame per Dwg 裏面沒有出現的，要在 Part List 出現，數量 ...
Andy2483 發表於 2025-10-28 11:26

[attach]38181[/attach]

作者: 198188 時間: 2025-10-28 11:48

回復 198188

Layout Dwg 分佈圖號在 Frame per Dwg 裏面沒有出現的，要在 Part List 出現，數量 ...
Andy2483 發表於 2025-10-28 11:26

[attach]38182[/attach]
Layout Dwg 分佈圖號在 Frame per Dwg 裏面沒有出現的，要在 Part List 出現，數量方式如上圖

作者: Andy2483 時間: 2025-10-28 11:59

本帖最後由 Andy2483 於 2025-10-28 12:27 編輯

回復 63# 198188

1.在 Frame per Dwg 有出現的, 在Part List 就不能出現嗎?
2.能抓個執行後錯誤的圖片跟正確的做一下說明?

作者: 198188 時間: 2025-10-28 12:43

回復 198188

1.在 Frame per Dwg 有出現的, 在Part List 就不能出現嗎?
2.能抓個執行後錯誤的 ...
Andy2483 發表於 2025-10-28 11:59

[attach]38183[/attach][attach]38184[/attach][attach]38185[/attach]

我將 Frame per Dwg & Part List 的規則和數量計算方式，重新用圖表列出説明附件Excel 及圖片

Frame per Dwg 只有一個規則

Part List 有兩個大規則，其中一個大規則附帶一個小規則

作者: Andy2483 時間: 2025-10-28 12:46

回復 65# 198188

篩出的資料是多出來還是短少了? 不懂困擾在哪裡?

作者: 198188 時間: 2025-10-28 13:58

回復 198188

篩出的資料是多出來還是短少了? 不懂困擾在哪裡?
Andy2483 發表於 2025-10-28 12:46

用#13的程式，資料出現什麽問題在#56説明

用#57 & #58 的程式，資料出現什麽問題在#59説明。

規則及範例在#65 説明。

作者: Andy2483 時間: 2025-10-28 14:00

回復 67# 198188

篩出的資料是多出來還是短少了?

作者: 198188 時間: 2025-10-28 14:09

回復 198188

篩出的資料是多出來還是短少了?
Andy2483 發表於 2025-10-28 14:00

Frame per Dwg 資料少了，應該用#13 的程式才對。
Frame per Dwg 内容規則：
在 Frame per Dwg 導出與 Layout Dwg 相同的分佈圖號，Layout Dwg相同圖號數量相加然後跟 Frame per Dwg 數量相乘

Part List資料少了，沒有含有 WS 的資料
Part List 内容規則：
1） Layout Dwg 分佈圖號在 Frame per Dwg 裏面沒有出現的，要在 Part List 出現，數量相乘
2）在上面規則下，附加多一個條件，如果 Part List 分佈圖號最後一個字母是小寫英文字母，那麽 Part List 分佈圖號包含 Layout Dwg 分佈圖號的也顯示出來。
3）Frame per Dwg 的組裝圖欄B 含有 WO No 的欄 F - K 各樣數據字母，要在 Part List 出現數量相乘

作者: Andy2483 時間: 2025-10-28 14:36

回復 69# 198188

1.本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加總,以下稱:LD合計數量) 要比對 Data Base 裡Part List表的G欄對應組裝號/加工件號
1.1.若吻合時整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量
1.1.若Data Base 裡Part List表G欄字串尾部多了個小寫英文字母去除後也吻合本檔的Layout Dwg表的A欄分佈圖號時,也整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量

2.本檔的Frame per Dwg表的B欄組裝圖號 (其E欄數量要加總,以下稱:FD合計數量) 也要比對 Data Base 裡Part List表的G欄對應組裝號/加工件號
2.1.若吻合時整列也帶出來到本檔的Part List,其中C欄的數量要*FD合計數量

以上敘述是否正確?

作者: 198188 時間: 2025-10-28 14:52

回復 198188

1.本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加總,以下稱D合計數量) 要比對 Dat ...
Andy2483 發表於 2025-10-28 14:36

Part List 表資料顯示規則如下：
1.本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加總,以下稱:LD合計數量) 要比對 Data Base 裡Part List表的G欄對應組裝號/加工件號
1.1.若吻合時整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量
1.1.若Data Base 裡Part List表G欄字串尾部多了個小寫英文字母去除後也吻合本檔的Layout Dwg表的A欄分佈圖號時,也整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量
以上正確

2.本檔的Frame per Dwg表的B欄組裝圖號 (其E欄數量要加總,以下稱:FD合計數量) 也要比對 Data Base 裡Part List表的G欄對應組裝號/加工件號
2.1 Frame per Dwg表的B欄組裝圖號需要含有 WO No 表的 F - K 欄的字母 WO No 表的 F - K 欄的字母有 "FG", 那麽只抽取 Frame per Dwg表的B欄組裝圖號含有 "FG"
2.2.若吻合時整列也帶出來到本檔的Part List,其中C欄的數量要*FD合計數量

Frame per Dwg 表資料顯示規則如下：
1. 本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加總,以下稱:LD合計數量) 要比對 Data Base 裡Frame per Dwg 表的A欄分佈圖號
1.1 若吻合時整列帶出來到本檔的Frame per Dwg,其中E欄的數量要*LD合計數量

作者: Andy2483 時間: 2025-10-28 15:10

回復 71# 198188

Part List 表資料顯示規則如下：
1.本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加總,以下稱:LD合計數量) 要比對 Data Base 裡Part List表的G欄對應組裝號/加工件號
1.1.若吻合時整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量
1.1.若Data Base 裡Part List表G欄字串尾部多了個小寫英文字母去除後也吻合本檔的Layout Dwg表的A欄分佈圖號時,也整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量
以上正確

2.本檔的Frame per Dwg表的B欄組裝圖號 (其E欄數量要加總,以下稱:FD合計數量) 也要比對 Data Base 裡Part List表的G欄對應組裝號/加工件號
2.1 Frame per Dwg表的B欄組裝圖號需要含有 WO No 表的 F - K 欄的字母 WO No 表的 F - K 欄的字母有 "FG", 那麽只抽取 Frame per Dwg表的B欄組裝圖號含有 "FG"
2.2.若吻合時整列也帶出來到本檔的Part List,其中C欄的數量要*FD合計數量

Frame per Dwg 表資料顯示規則如下：
3. 本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加總,以下稱:LD合計數量) 要比對 Data Base 裡Frame per Dwg 表的A欄分佈圖號
3.1 若吻合時整列帶出來到本檔的Frame per Dwg,其中E欄的數量要*LD合計數量
以上大致了解,另疑問:

4.有沒有重複的情況:
4.1.本檔的Layout Dwg表的A欄分佈圖號與本檔的Frame per Dwg表的B欄組裝圖號相同,會造成重複篩出?
4.2.如果有該如何處理

作者: 198188 時間: 2025-10-28 15:27

回復 198188

Part List 表資料顯示規則如下：
1.本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加 ...
Andy2483 發表於 2025-10-28 15:10

4.有沒有重複的情況:
4.1.本檔的Layout Dwg表的A欄分佈圖號與本檔的Frame per Dwg表的B欄組裝圖號相同,會造成重複篩出?
4.2.如果有該如何處理

1. 本檔 Layout Dwg 表的A欄分佈圖號會重複多個。(將相同分佈圖號歸納一個，數量加總，再讀取資料）
1.1. 重複分佈圖只抽取一次 Data Base 的 Frame per Dwg 表的A欄，因爲本檔 Layout Dwg 表的C欄數量已經加總，所以不影響其他數據。
1.2. 重複分佈圖只抽取一次 Data Base 的 Part List 表的 H 欄，因爲本檔 Layout Dwg 表的C欄數量已經加總，所以不影響其他數據。

2. 本檔Frame per Dwg 表的B欄組裝圖號也會重複多個。(將相同組裝圖號歸納一個，數量加總，再讀取資料）
2.1 重複分佈圖只抽取一次 Data Base 的 Part List 表的H欄，因爲本檔 Frame per Dwg 表的E欄數量已經加總，所以不影響其他數據。

作者: Andy2483 時間: 2025-10-28 15:52

本帖最後由 Andy2483 於 2025-10-28 15:54 編輯

回復 73# 198188

4.1.本檔的Layout Dwg表的A欄分佈圖號與本檔的Frame per Dwg表的B欄組裝圖號相同,會造成重複篩出?
這指的是兩表不同欄位,但卻是圖號相同的情況,造成篩出 Part List表兩筆以上相同資料,會有這種狀況嗎?
若有該如何處理?

例如:本檔的Layout Dwg表的A欄分佈圖號有 BW103, 本檔的Frame per Dwg表的B欄組裝圖號也有 BW103

作者: 198188 時間: 2025-10-28 16:06

回復 198188

4.1.本檔的Layout Dwg表的A欄分佈圖號與本檔的Frame per Dwg表的B欄組裝圖號相同 ...
Andy2483 發表於 2025-10-28 15:52

[attach]38188[/attach]

前輩指的是Part List 表要顯示的資料嗎？
兩者不衝突的
1. 本檔 Layout Dwg表是讀取 A欄分佈圖號（是取在本檔 Frame per Dwg 裏面沒有這個分佈圖的那些圖號）對應 Data Base 檔 Part List 欄 H 的分佈圖編號
2. 本檔 Frame per Dwg 表是讀取 B欄組裝圖號（是取在本檔 Frame per Dwg表 B欄組裝圖號含有 WO No. 的各樣數據）對應 Data Base 檔 Part List 欄 H 的分佈圖編號

作者: Andy2483 時間: 2025-10-28 16:43

回復 75# 198188

1. 本檔 Layout Dwg表是讀取 A欄分佈圖號（是取在本檔 Frame per Dwg 裏面沒有這個分佈圖的那些圖號）對應 Data Base 檔 Part List 欄 H 的分佈圖編號
8#的範例 Data Base.xlsx Part List表分佈圖編號在G欄 ,為什麼現在變成在H欄

作者: 198188 時間: 2025-10-28 16:53

回復 198188

1. 本檔 Layout Dwg表是讀取 A欄分佈圖號（是取在本檔 Frame per Dwg 裏面沒有 ...
Andy2483 發表於 2025-10-28 16:43

Data Base & 本檔的 Part List 都加插了一欄 “高度”
因爲 F 欄加插了一欄 “高度”方便後面制表時讀取資料。

作者: Andy2483 時間: 2025-10-28 17:12

回復 77# 198188

1.請重新上傳新的本檔與DTATA BASE檔
2.請重新說明規則

作者: 198188 時間: 2025-10-28 18:01

本帖最後由 198188 於 2025-10-28 18:02 編輯

回復 198188

1.請重新上傳新的本檔與DTATA BASE檔
2.請重新說明規則
Andy2483 發表於 2025-10-28 17:12

本檔 WO No 表資料顯示規則如下：與之前不變
1. 根據本檔 Read 表 A – C 欄資料 (批次次序, 樓層, 生產單號)，讀取 Data Base 檔 WO No 表 B – D欄 (批次次序, 樓層, 生產單號) 相同資料的一列

本檔 Layout Dwg 表資料顯示規則如下：與之前不變
1. 根據本檔 WO No 表 C 欄樓層和 B 欄批次次序，讀取 Data Base 檔 Layout Dwg 表B 欄樓層及D欄批次次序的相同資料一列

本檔 Frame per Dwg 表資料顯示規則如下：與之前不變
1. 本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加總,以下稱:LD合計數量) 要比對 Data Base 裡Frame per Dwg 表的A欄分佈圖號
1.1 若吻合時整列帶出來到本檔的Frame per Dwg,其中E欄的數量要*LD合計數量

本檔Part List 表資料顯示規則如下：
1.本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加總,以下稱:LD合計數量) 要比對 Data Base 裡Part List表的H欄對應組裝號/加工件號
1.1.若吻合時整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量
1.1.若Data Base 裡Part List表H欄字串尾部多了個小寫英文字母去除後也吻合本檔的Layout Dwg表的A欄分佈圖號時,也整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量
以上正確

2.本檔的Frame per Dwg表的B欄組裝圖號 (其E欄數量要加總,以下稱:FD合計數量) 也要比對 Data Base 裡Part List表的H欄對應組裝號/加工件號
2.1 Frame per Dwg表的B欄組裝圖號需要含有 WO No 表的 F - K 欄的字母 WO No 表的 F - K 欄的字母有 "FG", 那麽只抽取 Frame per Dwg表的B欄組裝圖號含有 "FG"
2.2.若吻合時整列也帶出來到本檔的Part List,其中C欄的數量要*FD合計數量

作者: Andy2483 時間: 2025-10-29 08:56

回復 79# 198188

本檔與DATA BASE1檔都各有一個 Material表,兩表有何關係?

作者: 198188 時間: 2025-10-29 10:38

回復 198188

本檔與DATA BASE1檔都各有一個 Material表,兩表有何關係?
Andy2483 發表於 2025-10-29 08:56

兩個Material表是一樣的，因為Data Base 比較大，上載不了，之前製表時方便前輩看該表格式，所以就轉移到本檔。
所以本檔的Material表是不要的。

作者: Andy2483 時間: 2025-10-29 10:56

回復 81# 198188

如果本檔的Material表是不要的! 後續執行 Sub Form() 時需要再啟一次 DATA BAS1檔案才能讀到 Material表的資料
所以請問 Sub Data() 和 Sub Form() 這兩個程式是以下哪種需求?
1.按一次鈕後兩個程式接續執行完得到.PDF檔
2.按鈕Sub Data()先執行後,手動編輯本檔,再按鈕執行 Sub Form() 得到.PDF檔
3.其他

作者: 198188 時間: 2025-10-29 14:12

回復 198188

如果本檔的Material表是不要的! 後續執行 Sub Form() 時需要再啟一次 DATA BAS1檔案才能 ...
Andy2483 發表於 2025-10-29 10:56

sub Data 是打開Data base 讀取 WO NO ，LAYOUT PER DWG， FRAME PER DWG， PART LIST。

SUB FORM 是生產新表單，然後打開Data base，讀取material資料，並生產PSD。

作者: Andy2483 時間: 2025-10-29 14:18

回復 83# 198188

請選擇 1 ,2 或3

作者: 198188 時間: 2025-10-29 14:38

回復 198188

請選擇 1 ,2 或3
Andy2483 發表於 2025-10-29 14:18

選擇3, 分開3個鍵，一個執行DATA 一個執行 FORM,一個執行打印PDF

作者: Andy2483 時間: 2025-10-29 14:52

回復 85# 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 Base1.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)) = ""
          '↑令WO No表的 F-K 欄的字母前方連接"|"字元當key,item是空字元納入Z字典
      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").[A1].CurrentRegion
For i = 2 To UBound(Brr)
If Z.Exists(Brr(i, 2)) And Brr(i, 4) = Sheets("Read").[A2] Then
    '↑如果B欄樓層及 D欄批次次序吻合
   Z(Brr(i, 1)) = Z(Brr(i, 1)) + Val(Brr(i, 3))
   '↑本檔的Layout Dwg表的A欄分佈圖號(其C欄數量要加總,以下稱:LD合計數量)
   N = N + 1
   For j = 1 To 4: Brr(N, j) = Brr(i, j): Next
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
Brr = xBook.Sheets("Frame per Dwg").[A1].CurrentRegion
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, 5) = Brr(N, 5) * Z(Brr(i, 1))
    '↑本檔的Frame per Dwg,其中E欄的數量要*LD合計數量
   If Z(Brr(i, 2)) > 0 Then
      MsgBox "Layout Dwg表A欄(分佈圖號)與 Frame per Dwg表B欄(組裝圖號)重複" & vbLf & vbLf & Brr(i, 2)
      Exit Sub
   End If
   Z(Brr(i, 2) & "/") = Z(Brr(i, 2) & "/") + Brr(N, 5)
    '↑本檔的Frame per Dwg表的B欄組裝圖號 (其E欄數量要加總,以下稱:FD合計數量)
End If
Next
If N > 0 Then Sheets("Frame per Dwg").[A2].Resize(N, 6) = Brr: N = 0 Else MsgBox "Frame per Dwg_Nothing"
Brr = xBook.Sheets("Part List").[A1].CurrentRegion
ReDim Arr(1 To 100000, 1 To 13): 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) > 0 Or Z(Q) > 0 Then
   N = N + 1
   For j = 1 To 13: Arr(N, j) = Brr(i, j): Next
   Arr(N, 3) = Arr(N, 3) * (Z(T) + Z(Q))
End If
'↑1.本檔的Layout Dwg表的A欄分佈圖號要比對 Data Base 裡Part List表的H欄分佈圖編號
'1.1.若吻合時整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量
'1.1.若Data Base 裡Part List表H欄字串尾部多了個小寫英文字母去除後也吻合本檔的Layout Dwg表的A欄分佈圖號時,也整列帶出來到本檔的Part List,其中C欄的數量要*LD合計數量
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, 3) = Crr(R, 3) * Z(T & "/")
   '↑2.本檔的Frame per Dwg表的B欄組裝圖號(前2字元含有 WO No 表的 F - K 欄的字母) 要比對 Data Base 裡Part List表的H欄分佈圖編號
   '2.1.若吻合時整列帶出來到本檔的Part List,其中C欄的數量要*FD合計數量
End If
Next
If N > 0 Then
With Sheets("Part List").[A2].Resize(N, 13)
   .Value = Arr
   .Interior.ColorIndex = 35
   '↑分佈圖號帶出來的儲存格底色是綠色
End With
End If
If R > 0 Then
With Sheets("Part List").Cells(N + 2, 1).Resize(R, 13)
   .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

作者: 198188 時間: 2025-10-30 09:05

回復 198188

先測試 DATA:
Sub Data()
Dim Arr, Brr, Crr, Z, Q, S, i&, j%, N&, T$, T1$, My ...
Andy2483 發表於 2025-10-29 14:52

[attach]38196[/attach][attach]38197[/attach]

運行後，出現Part List nothing, 但是基於規則應該有資料顯示，如上附圖。黃色部分應該顯示在Part List

作者: Andy2483 時間: 2025-10-30 09:21

本帖最後由 Andy2483 於 2025-10-30 09:23 編輯

回復 87# 198188

同樣條件執行結果如下:
[attach]38198[/attach]

[attach]38199[/attach]
請檢視提供的範例與實際執行檔案欄位是否相同

作者: 198188 時間: 2025-10-30 10:04

回復 198188

同樣條件執行結果如下:

請檢視提供的範例與實際執行檔案欄位是否相同
Andy2483 發表於 2025-10-30 09:21

[attach]38200[/attach]
欄位沒有錯，Layout Dwg, Frame per Dwg 都有資料導出，只有 Part List 沒有資料導出。

作者: Andy2483 時間: 2025-10-30 10:09

回復 89# 198188

請上傳範例本檔
DATA BAS1 不需要

作者: 198188 時間: 2025-10-30 10:12

回復 198188

請上傳範例本檔
DATA BAS1 不需要
Andy2483 發表於 2025-10-30 10:09

附件是運行後的本檔

作者: Andy2483 時間: 2025-10-30 10:21

本帖最後由 Andy2483 於 2025-10-30 10:30 編輯

回復 91# 198188

執行後有資料,如88樓結果
請檢察BATA BASE1檔案 Part List表資料是否有斷行(資料中間有橫的空列)

'-----------------------------------------------------補充
.如果有斷行:請將 [A1].CurrentRegion 這些字置換成 UsedRange

作者: 198188 時間: 2025-10-30 10:31

回復 198188

執行後有資料,如88樓結果
請檢察BATA BASE1檔案 Part List表資料是否有斷行(資料中 ...
Andy2483 發表於 2025-10-30 10:21

檢查了Data Base 檔案的Part List 表資料，共45135行，Column A, B, C,D, E, G, H 中間都沒有斷行。

作者: Andy2483 時間: 2025-10-30 10:35

回復 93# 198188

請將 [A1].CurrentRegion 這些字置換成 UsedRange ,共有3處後,再試試看

作者: 198188 時間: 2025-10-30 10:37

回復 198188

執行後有資料,如88樓結果
請檢察BATA BASE1檔案 Part List表資料是否有斷行(資料中 ...
Andy2483 發表於 2025-10-30 10:21

[attach]38202[/attach]
按你指示修改了，執行後出現錯誤。
Brr = xBook.Sheets("Part List").[A1].CurrentRegion 修改前
Brr = xBook.Sheets("Part List").[A1].UsedRange 修改後

作者: 198188 時間: 2025-10-30 10:38

回復 198188

請將 [A1].CurrentRegion 這些字置換成 UsedRange ,共有3處後,再試試看
Andy2483 發表於 2025-10-30 10:35

修改後出現上貼錯誤

作者: Andy2483 時間: 2025-10-30 10:40

回復 96# 198188

[A1]. 也要換掉

作者: 198188 時間: 2025-10-30 10:43

回復 198188

[A1]. 也要換掉
Andy2483 發表於 2025-10-30 10:40

[attach]38203[/attach]
換了，Part List 也顯示Nothing

作者: Andy2483 時間: 2025-10-30 10:53

回復 98# 198188

會不會是系統語言不同造成的差異,請試試以下代碼

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 Base1.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
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)
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) > 0 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

作者: Andy2483 時間: 2025-10-30 11:12

本帖最後由 Andy2483 於 2025-10-30 11:13 編輯

回復 98# 198188

請將 RunForm Module 裡的 Sub Data()代碼全部刪除,程式名稱與 RunData Module Sub Data()重複了

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)