- 帖子
- 1567
- 主題
- 40
- 精華
- 0
- 積分
- 1591
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-12-8
|
回復 130# 198188
前輩沒先傳DATA OK版本給後學確認,那就再請前輩確認以下方案是否符合需求
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
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(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(Q)
Arr(N, 3) = Arr(N, 3) * 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 |
|
發表於 2025-10-30 17:59
| 
