- 帖子
- 573
- 主題
- 72
- 精華
- 0
- 積分
- 670
- 點名
- 1
- 作業系統
- win7
- 軟體版本
- office 2010
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-10-30
- 最後登錄
- 2025-12-1
|
本帖最後由 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 那裏卡住，不懂得新增。 |
|
發表於 2025-10-23 08:12
| 
