12
返回列表 上一主題 發帖

請問規則02F - 04F 如果在Data Base 篩選在這個範圍内的相關資料

198188

帖子
456 
主題
71 
精華
0 
積分
552 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-10-13 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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

帖子
456 
主題
71 
精華
0 
積分
552 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-10-13 
2#
發表於 2025-10-5 16:20 | 只看該作者

Desktop.rar (146.89 KB)

TOP

hcm19522

帖子
1423 
主題
6 
精華
0 
積分
1435 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2025-10-14 

熱烈參與勳章
3#
發表於 2025-10-6 11:19 | 只看該作者
B2=VLOOKUP($A2,'[Data Base.xlsx]WO No'!$A:$K,COLUMN(B1),)
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

198188

帖子
456 
主題
71 
精華
0 
積分
552 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-10-13 
4#
發表於 2025-10-6 11:36 | 只看該作者
本帖最後由 198188 於 2025-10-6 11:38 編輯

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）

TOP

198188

帖子
456 
主題
71 
精華
0 
積分
552 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-10-13 
5#
發表於 6 天前 09:11 | 只看該作者
本帖最後由 198188 於 2025-10-8 09:16 編輯
  1. Sub Copy_Layout_To_Data() 'ok!
  2.         Dim h, i, j As Integer
  3.         Dim myString, myString1 As String
  4.         Dim charToFind, charToFind1, charToFind2 As String
  5.         Dim position, position1, position2, position3 As Long
  6.         Dim stringLength, stringLength1 As Long
  7.         j = 2
  8.         
  9.         h = Worksheets("Layout Dwg").Cells(Rows.Count, 1).End(3).Row
  10.         h = h + 1
  11.         
  12.         myString = Sheets("Data").Range("C2")
  13.         stringLength = Len(myString)
  14.         charToFind = "-" ' Searching for lowercase '-' in "World"
  15.         position = InStr(1, myString, charToFind, vbTextCompare)

  17.         If position > 0 Then
  18.         
  19.         a = Mid(myString, 1, position - 2)
  20.         b = Mid(myString, position + 1, stringLength - position - 1)
  21.         
  22.         For i = 2 To h
  23.         Sheets("Layout Dwg").Select
  24.         myString1 = Range("B" & i)
  25.         charToFind2 = "F" ' Searching for lowercase 'F' in "World"
  26.         position2 = InStr(1, myString1, charToFind2, vbTextCompare)
  27.         
  28.         If position2 > 0 Then
  29.         c = Mid(myString1, 1, position2 - 1)
  30.         If c = a Then
  31.         Sheets("Layout Dwg").Select
  32.         Range("A" & i & ":C" & i).Select
  33.         Selection.Copy
  34.         Sheets("Data").Select
  35.         Range("M" & j).Select
  36.         ActiveSheet.Paste
  37.         j = j + 1
  38.         Else
  39.         If c > a And c <= b Then
  40.         Sheets("Layout Dwg").Select
  41.         Range("A" & i & ":C" & i).Select
  42.         Selection.Copy
  43.         Sheets("Data").Select
  44.         Range("M" & j).Select
  45.         ActiveSheet.Paste
  46.         j = j + 1
  47.         End If
  48.         End If
  49.         End If
  50.         Next i
  51.         
  52.         Else
  53.         charToFind1 = "&" ' Searching for lowercase '&' in "World"
  54.         position1 = InStr(1, myString, charToFind1, vbTextCompare)
  55.         If position1 > 0 Then
  56.         Z = Mid(myString, 1, position1 - 1)
  57.         y = Mid(myString, position1 + 1, stringLength - position1)
  58.         
  59.         For i = 2 To h
  60.         
  61.         Sheets("Layout Dwg").Select
  62.         c = Range("B" & i)
  63.         If c = Z Or c = y Then
  64.         Sheets("Layout Dwg").Select
  65.         Range("A" & i & ":C" & i).Select
  66.         Selection.Copy
  67.         Sheets("Data").Select
  68.         Range("M" & j).Select
  69.         ActiveSheet.Paste
  70.         j = j + 1
  71.         End If
  72.         
  73.         Next i
  74.         
  75.         Else
  76.         W = myString
  77.         For i = 2 To h
  78.         
  79.         Sheets("Layout Dwg").Select
  80.         c = Range("B" & i)
  81.         If c = W Then
  82.         Sheets("Layout Dwg").Select
  83.         Range("A" & i & ":C" & i).Select
  84.         Selection.Copy
  85.         Sheets("Data").Select
  86.         Range("M" & j).Select
  87.         ActiveSheet.Paste
  88.         j = j + 1
  89.         End If
  90.         Next i
  91.         
  92.         End If
  93.         End If
  94.     End Sub
複製代碼
這個并非我的問題要求。
我意思是說，
我輸入02F-04F （圖1)
就會自動抽取 Layout Dwg 表裏欄 B 樓層 ...
198188 發表於 2025-10-6 11:36

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

Data Base.rar (162.25 KB)

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1465 
主題
40 
精華
0 
積分
1489 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2025-10-14 
6#
發表於 6 天前 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

198188

帖子
456 
主題
71 
精華
0 
積分
552 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-10-13 
7#
發表於 6 天前 16:29 | 只看該作者
本帖最後由 198188 於 2025-10-8 16:49 編輯
回復  198188


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

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


感謝前輩指點

TOP

198188

帖子
456 
主題
71 
精華
0 
積分
552 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-10-13 
8#
發表於 5 天前 17:30 | 只看該作者
回復  198188


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

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




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

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

WO-J057-022.rar (170.02 KB)

Data Base.rar (151.58 KB)

TOP

198188

帖子
456 
主題
71 
精華
0 
積分
552 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-10-13 
9#
發表於 4 天前 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 "對應組裝號/加工件號" 相同的"組裝圖號"，及數量相乘。
  1. For i = 2 To UBound(Brr)
  2.    If Z.Exists(Brr(i, 2)) Then
  3.    If Brr(i, 4) = Sheets("Read").[A2] Then
  4.       Z(Brr(i, 1)) = Z(Brr(i, 1)) + Val(Brr(i, 3))
  5.       N = N + 1
  6.       For j = 1 To 4: Brr(N, j) = Brr(i, j): Next
  7.    End If
  8.    End If
  9. Next
  10. If N > 0 Then Sheets("Layout Dwg").[A2].Resize(N, 4) = Brr: N = 0 Else MsgBox "Nothing under the floor": GoTo 12
複製代碼

TOP

198188

帖子
456 
主題
71 
精華
0 
積分
552 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2012-10-30 
最後登錄
2025-10-13 
10#
發表於 昨天 10:25 | 只看該作者
  1. Set Z = CreateObject("Scripting.Dictionary")

  3. xFile = "Data Base.xlsx"

  5. Set xBook = Workbooks(xFile)



  9. a = Sheets("WO No").Range("F2")
  10. b = Sheets("WO No").Range("G2")
  11. c = Sheets("WO No").Range("H2")
  12. d = Sheets("WO No").Range("I2")
  13. e = Sheets("WO No").Range("J2")
  14. f = Sheets("WO No").Range("K2")


  17. G = Sheets("Part List").Range("A1").CurrentRegion.Rows.Count + 1

  19. Brr = Sheets("Frame per Dwg").[A1].CurrentRegion
  20.   For i = 2 To UBound(Brr)
  21.   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
  22.    Z(Brr(i, 2)) = Z(Brr(i, 2))
  23.       N = N + 1
  24.       For j = 1 To 6: Brr(N, j) = Brr(i, j): Next
  25.    End If

  27. Next

  29. N = 1
  30. Arr = xBook.Sheets("Part List").[A1].CurrentRegion
  31. For i = 2 To UBound(Arr)
  32.    If Z.Exists(Arr(i, 7)) Then
  33.       N = N + 1
  34.       For j = 1 To 13
  35.       Arr(N, j) = Arr(i, j)
  36.       Next j
  37.       Arr(N, 5) = Arr(N, 5) * Z(Arr(i, 7))
  38.    End If
  39. Next
  40. 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 補充方面也解決，但是無法套入相同模組，需要獨立開一個模組。還有複製時，總是會複雜第一欄的名目。

TOP

        靜思自在 : 【做人的開始】每一天都是故人的開始，每一個時刻都是自己的警惕。
12
返回列表 上一主題