1234567
返回列表 上一主題 發帖

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

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

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
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

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
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

qaqa3296

帖子
45 
主題
7 
精華
0 
積分
102 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE 2016 
閱讀權限
20 
註冊時間
2019-4-27 
最後登錄
2025-6-1 
34#
發表於 2020-8-23 12:21 | 只看該作者
回復 33# 軒云熊

感謝軒云熊改進程式碼

資料還差一些

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

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

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

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
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

帖子
45 
主題
7 
精華
0 
積分
102 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE 2016 
閱讀權限
20 
註冊時間
2019-4-27 
最後登錄
2025-6-1 
36#
發表於 2020-8-25 20:44 | 只看該作者
回復 35# 軒云熊

目前測試

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

TOP

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
37#
發表於 2020-8-25 21:02 | 只看該作者
回復 36# 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 = 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 <> "" And Sheets(1).Cells(K, 3) <> "" 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

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
38#
發表於 2020-8-25 21:30 | 只看該作者
回復 36# 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 = 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 <> "" And Sheets(1).Cells(K, 3) <> "" 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 Sheets(1).Cells(K, 2) <> "" Then
                 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
            
            
        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

軒云熊

帖子
254 
主題
6 
精華
0 
積分
310 
點名
0  
作業系統
W10 
軟體版本
Excel 2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2019-6-16 
最後登錄
2024-9-23 
39#
發表於 2020-8-25 22:32 | 只看該作者
回復 38# 軒云熊
如果是 品號 品名 規格 數量 其中一個忘記打 可以試試這個:)
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 Sheets(1).Cells(2, 4).End(xlDown).Row
    X = Trim(Sheets(1).Cells(K, 3))
   
    If Sheets(1).Cells(K, 1) = "" And Sheets(1).Cells(K, 2) = "" And Sheets(1).Cells(K, 3) = "" And Sheets(1).Cells(K, 4) = "" Then
       Exit For
    End If
   
    For i = 2 To Cells(2, 3).End(xlDown).Row '依條件篩選

        If X <> "" And Sheets(1).Cells(K, 3) <> "" 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 Sheets(1).Cells(K, 2) <> "" Then
                 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
            
            
        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

帖子
45 
主題
7 
精華
0 
積分
102 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE 2016 
閱讀權限
20 
註冊時間
2019-4-27 
最後登錄
2025-6-1 
40#
發表於 2020-8-25 23:55 | 只看該作者
回復 38# 軒云熊

程式思路走偏了。

重申題目要點：
不要以品名為基準查詢，重複與多餘資料太多沒有參考價值
規格空白又不能查品名，那還有什麼可以列，所以想到了嗎?








應該去檢查的是你的
If X = "" Then
裡面的迴圈

改完就沒有什麼大問題了，程式核心接近需求，但不知有沒有其他BUG。

沒基礎剛開始學習，但好像看懂你程式再做什麼了，F8好用

算是互相學習吧

TOP

        靜思自在 : 看別人不順眼，是自己修養不夠。
1234567
返回列表 上一主題