- 帖子
- 582
- 主題
- 75
- 精華
- 0
- 積分
- 682
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office 2010
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-10-30
- 最後登錄
- 2026-4-13
|
121#
發表於 2025-10-31 07:43
| 只看該作者
- 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
- For i = 1 To N
- Brr(i, 1) = i
- Next
- Sheets("Frame per Dwg").[A1] = " No "
- 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): T1 = Brr(i, 7)
- If (Z(T) > 0 Or Z(Q) > 0) And InStr("YO", T1) > 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)) And InStr("YO", T1) = 0 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
回復 198188
1.這程式碼已經亂掉了,全部都刪除
2.複製99 樓的程式碼貼進去
3.用116樓的程式 ...
Andy2483 發表於 2025-10-30 22:26 
前輩，換了之後，執行出現這個問題。 |
|
