列出更多的對應資料 - Excel程式區

qaqa3296

中學生 Rank: 2

帖子: 45
主題: 7
精華: 0
積分: 102
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2016
閱讀權限: 20
註冊時間: 2019-4-27
最後登錄: 2025-10-12

36^# 跳轉到 »

發表於 2020-8-25 20:44 | 只看該作者

回復 35# 軒云熊

目前測試

如果規格為空白(忘記打)，依當初定的條件來看，只會列出那列的資料，但看起來你把該列有相同品名的關鍵字全部找出來了。

TOP

軒云熊

中學生 Rank: 2

帖子: 254
主題: 6
精華: 0
積分: 310
點名: 0
作業系統: W10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2019-6-16
最後登錄: 2025-6-21

35^#

發表於 2020-8-24 22:33 | 只看該作者

本帖最後由軒云熊於 2020-8-24 22:41 編輯

回復 34# qaqa3296
沒辦法了想不出來文字的格式太複雜了...  如果是用 asc 方法會寫得更長....只能借用准提部林大大還有 n7822123大大們的邏輯...才能辦到 >"<
Public Sub 模糊篩選()

Application.ScreenUpdating = False
Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(255, 0, 0)
G = True
Sheets(3).Select
Sheets(3).Range(Cells(1, 1), Cells(1, 4).End(xlDown)).Clear
Sheets(2).Select

For K = 2 To Cells(2, 5).End(xlDown).Row
X = Trim(Sheets(1).Cells(K, 3))
If Sheets(1).Cells(K, 1) = "" Then Exit For

For i = 2 To Cells(2, 3).End(xlDown).Row '依條件篩選

      If X <> "" Then

         Sheets(2).Cells(2, 3).AutoFilter
         Cells(i, 1).AutoFilter Field:=3, Criteria1:="=*" & Mid(X, 1, 8) & "*", Operator:=xlOr, Criteria2:="=" & X & ""
         Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)

         Cells(i, 1).AutoFilter Field:=3, Criteria1:="=*" & Mid(X, 1, 5) & "*", Operator:=xlOr, Criteria2:="=" & X & ""
         Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)

         If X Like "####[-.]*" Or X Like "####[A-Z]*" Then
            Cells(i, 1).AutoFilter Field:=3, Criteria1:="=*" & Mid(X, 1, 4) & "*", Operator:=xlOr, Criteria2:="=" & X & ""
            Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
         End If

         If ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas.Count = 1 Then
            Sheets(2).Cells(2, 3).AutoFilter
            Cells(i, 1).AutoFilter Field:=2, Criteria1:="=*" & X & "*", Operator:=xlOr, Criteria2:="=" & X & ""
            Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)

            Cells(i, 1).AutoFilter Field:=2, Criteria1:=Sheets(1).Cells(K, 2)
            Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
         End If
      End If

      If X = "" Then
         X = Trim(Sheets(1).Cells(K, 2))
         Cells(i, 1).AutoFilter Field:=2, Criteria1:="=*" & X & "*", Operator:=xlOr, Criteria2:=Sheets(1).Cells(K, 2)
         Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
         If ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas.Count = 1 Then
            Sheets(2).Cells(2, 3).AutoFilter
            Cells(i, 1).AutoFilter Field:=1, Criteria1:=Sheets(1).Cells(K, 1)
            Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
         If ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas.Count = 1 Then
         Exit For
         End If
            Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
         End If
      End If

Exit For
Next i

If G = True Then
      Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, 4).End(xlDown)).Copy Sheets(3).Cells(1, 1)
      G = False
Else
      Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Copy Sheets(3).Cells(1, 1).End(xlDown).Offset(1, 0)
End If
Sheets(2).Cells(2, 3).AutoFilter

Next K
Sheets(3).Select
Range(Sheets(3).Cells(2, 1), Sheets(3).Cells(2, 4).End(xlDown)).RemoveDuplicates Columns:=1
Range(Sheets(3).Cells(2, 1), Sheets(3).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
Application.ScreenUpdating = True
End Sub

TOP

qaqa3296

中學生 Rank: 2

帖子: 45
主題: 7
精華: 0
積分: 102
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2016
閱讀權限: 20
註冊時間: 2019-4-27
最後登錄: 2025-10-12

34^#

發表於 2020-8-23 12:21 | 只看該作者

回復 33# 軒云熊

感謝軒云熊改進程式碼

資料還差一些

你的程式執行完後必須刪除重複項目

附上我最終需要的顯示效果與准大比較，這樣比較容易觀看

列出更多資料V7資料呈現.zip (49.29 KB)

TOP

軒云熊

中學生 Rank: 2

帖子: 254
主題: 6
精華: 0
積分: 310
點名: 0
作業系統: W10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2019-6-16
最後登錄: 2025-6-21

33^#

發表於 2020-8-23 10:39 | 只看該作者

如果是品名還有規格打錯字我是改這樣但是規格的結果跟準大的不同
Public Sub 模糊篩選()
Application.ScreenUpdating = False
Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(255, 0, 0)
G = True
Sheets(3).Select
Sheets(3).Range(Cells(1, 1), Cells(1, 4).End(xlDown)).Clear
Sheets(2).Select

For K = 2 To Cells(2, 5).End(xlDown).Row
x = Sheets(1).Cells(K, 3)
If Sheets(1).Cells(K, 1) = "" Then Exit For
For i = 2 To Cells(2, 3).End(xlDown).Row '依條件篩選

      If Sheets(1).Cells(K, 3) = "" And Asc(Sheets(1).Cells(K, 2)) > 127 Or Asc(Sheets(1).Cells(K, 2)) < 0 Then
         Cells(i, 1).AutoFilter Field:=2, Criteria1:=Sheets(1).Cells(K, 2)
         Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)

         If Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Count - 1 And Sheets(1).Cells(K, 3) = "" Then
            Sheets(2).Cells(2, 3).AutoFilter
            Cells(i, 1).AutoFilter Field:=1, Criteria1:=Sheets(1).Cells(K, 1)
            Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
            If Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Count - 1 And Sheets(1).Cells(K, 3) <> "" Then
                  Sheets(2).Cells(2, 3).AutoFilter
                  Cells(i, 1).AutoFilter Field:=1, Criteria1:=Sheets(1).Cells(K, 1)
                  Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
            End If
         End If

      Else
         Cells(i, 1).AutoFilter Field:=3, Criteria1:="*" & x & "*"
         Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
      End If

      If G = True Then
         Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, 4).End(xlDown)).Copy Sheets(3).Cells(1, 1)
         G = False
      Else
         Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Copy Sheets(3).Cells(1, 1).End(xlDown).Offset(1, 0)
      End If
      Sheets(2).Cells(2, 3).AutoFilter
Exit For
Next i
Next K
Sheets(3).Select
Range(Sheets(3).Cells(2, 1), Sheets(3).Cells(2, 4).End(xlDown)).RemoveDuplicates Columns:=1
Range(Sheets(3).Cells(2, 1), Sheets(3).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
Application.ScreenUpdating = True
End Sub

TOP

軒云熊

中學生 Rank: 2

帖子: 254
主題: 6
精華: 0
積分: 310
點名: 0
作業系統: W10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2019-6-16
最後登錄: 2025-6-21

32^#

發表於 2020-8-23 03:52 | 只看該作者

本帖最後由軒云熊於 2020-8-23 04:05 編輯

謝謝 n7822123 前輩的鼓勵  每寫一次我就會多一次經驗我會繼續努力的:P

回復 30# qaqa3296

抱歉沒有注意到我改這樣你看看是不是這樣的結果

Public Sub 模糊篩選()
Application.ScreenUpdating = False
Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(255, 0, 0)
G = True
Sheets(3).Select
Sheets(3).Range(Cells(1, 1), Cells(1, 4).End(xlDown)).Clear
Sheets(2).Select

For K = 2 To Cells(2, 5).End(xlDown).Row
x = Sheets(1).Cells(K, 3)
If Sheets(1).Cells(K, 1) = "" Then Exit For
For i = 2 To Cells(2, 3).End(xlDown).Row '依條件篩選

      If Sheets(1).Cells(K, 3) = "" And Asc(Sheets(1).Cells(K, 2)) > 127 Or Asc(Sheets(1).Cells(K, 2)) < 0 Then
         Cells(i, 1).AutoFilter Field:=2, Criteria1:=Sheets(1).Cells(K, 2)
         Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)

         If Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Count - 1 And Sheets(1).Cells(K, 3) = "" Then
            Sheets(2).Cells(2, 3).AutoFilter
            Cells(i, 1).AutoFilter Field:=1, Criteria1:=Sheets(1).Cells(K, 1)
            Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
         End If

      Else
         Cells(i, 1).AutoFilter Field:=3, Criteria1:="*" & x & "*"
         Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
      End If

      If G = True Then
         Range(Sheets(2).Cells(1, 1), Sheets(2).Cells(1, 4).End(xlDown)).Copy Sheets(3).Cells(1, 1)
         G = False
      Else
         Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(2, 4).End(xlDown)).Copy Sheets(3).Cells(1, 1).End(xlDown).Offset(1, 0)
      End If
      Sheets(2).Cells(2, 3).AutoFilter
Exit For
Next i
Next K
Sheets(3).Select
Range(Sheets(3).Cells(2, 1), Sheets(3).Cells(2, 4).End(xlDown)).RemoveDuplicates Columns:=1
Range(Sheets(3).Cells(2, 1), Sheets(3).Cells(2, 4).End(xlDown)).Font.Color = RGB(0, 0, 0)
Application.ScreenUpdating = True
End Sub
javascript:;

列出更多資料V6001.rar (32.59 KB)

TOP

n7822123

　暱稱: 阿龍

中學生 Rank: 2

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

31^#

發表於 2020-8-22 23:12 | 只看該作者

本帖最後由 n7822123 於 2020-8-22 23:16 編輯

回復 29# 軒云熊

你可以繼續努力~~

自己辛苦寫出來的程式，會很有成就感!

學習就是不斷嘗試錯誤的過程~

相反，如果只抄別人的程式，就認為自己已經會的那種人....是學不好的

以為自己已經看懂，但就是不能自己寫出來~

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

qaqa3296

中學生 Rank: 2

帖子: 45
主題: 7
精華: 0
積分: 102
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2016
閱讀權限: 20
註冊時間: 2019-4-27
最後登錄: 2025-10-12

30^#

發表於 2020-8-22 22:59 | 只看該作者

回復 29# 軒云熊

1.看你列出的資料你該不會...

目標品名打錯字就會列出資料缺少。庫存內品名有重複就會多列資料? 這...

上面有補充說明：不要以品名為基準查詢，重複與多於資料太多沒有參考價值

TOP

軒云熊

中學生 Rank: 2

帖子: 254
主題: 6
精華: 0
積分: 310
點名: 0
作業系統: W10
軟體版本: Excel 2016
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2019-6-16
最後登錄: 2025-6-21

29^#

發表於 2020-8-22 21:47 | 只看該作者

回復 26# qaqa3296

我是用鍵字篩選的方式  看起來結果是一樣的  但我不知道是不是你要求的
不過準大已經達到你的目的  也給了我學習的機會


javascript:;

列出更多資料V6001.rar (31.01 KB)

TOP

qaqa3296

中學生 Rank: 2

帖子: 45
主題: 7
精華: 0
積分: 102
點名: 0
作業系統: WIN7
軟體版本: OFFICE 2016
閱讀權限: 20
註冊時間: 2019-4-27
最後登錄: 2025-10-12

28^#

發表於 2020-8-22 21:22 | 只看該作者

回復 27# 准提部林

程式列出的資料非常完整，感謝准提部林提供另外的寫法供大家學習

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2843
主題: 10
精華: 0
積分: 2899
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2025-10-18

27^#

發表於 2020-8-22 18:22 | 只看該作者

Sub TEST_V1()
Dim Arr, A, xD, i&, j%, N&, T$, V%
[成果!A2:D6000].ClearContents
Set xD = CreateObject("scripting.dictionary")
Arr = Range([目標!C1], [目標!A65536].End(xlUp))
For i = 2 To UBound(Arr)
T = Trim(Arr(i, 1)): If T <> "" Then xD(T) = 1
T = 拆解編號(Trim(Arr(i, 3))): If T = "" Then GoTo 101
For Each A In Split(T, "/"): xD(A & "") = 1: Next
101: Next i
Arr = Range([庫存!D1], [庫存!A65536].End(xlUp))
For i = 2 To UBound(Arr)
If xD("|" & i) > 0 Then GoTo 102 '如果該行已被提取過, 略過, 避免重覆提取
T = Trim(Arr(i, 1)): If Val(xD(T)) > 0 Then V = 1: GoTo 999 '[品號]相符即直接提取
T = Trim(Arr(i, 3)): If T = "" Then GoTo 102
T = 拆解編號(T) '拆解[規格]
For Each A In Split(T, "/")
If A <> "" And Val(xD(A & "")) > 0 Then V = 1: Exit For
Next
999:
If V = 0 Then GoTo 102
N = N + 1: V = 0
For j = 1 To 4: Arr(N, j) = Trim(Arr(i, j)): Next
xD("|" & i) = 1 '已提取行號位置,記錄入字典
102: Next i
If N > 0 Then [成果!A2:D2].Resize(N) = Arr
End Sub

'==========================================
Function 拆解編號(xS$) As String
Dim TT$, j%, ST$
If xS = "" Then Exit Function
If Left(xS, 4) Like "####" Then TT = Left(xS, 4)
If Left(xS, 5) Like "####[A-Z]" Then TT = Left(xS, 5) & "/" & TT
If Left(xS, 5) Like "[A-Z]####" Then TT = Left(xS, 5) & "/" & TT
If Left(xS, 8) Like "???-????" Then TT = Left(xS, 8) & "/" & TT
xS = xS & "-"
For j = Len(TT) + 2 To Len(xS)
If Mid(xS, j, 1) Like "[-.(]" Then TT = Left(xS, j - 1) & "/" & TT
Next j
拆解編號 = TT
End Function

模糊中又不能亂抓, 難~~~

TOP

[發問] 列出更多的對應資料

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]