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

軒云熊

中學生 Rank: 2

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

1^# 跳轉到 »

發表於 2020-8-21 18:09 | 顯示全部帖子

本帖最後由軒云熊於 2020-8-21 18:16 編輯

回復 9# qaqa3296
我的寫法比較簡單但是會比較慢你看看是不是你要的如果是文字你就打文字列如煞車用第二個如果是原本的空格你就用第一個

javascript:;

列出更多資料.rar (20.27 KB)

TOP

軒云熊

中學生 Rank: 2

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

2^#

發表於 2020-8-21 23:20 | 顯示全部帖子

如果你只是要避免讓別人打錯那你就用自訂表單比較好吧...

TOP

軒云熊

中學生 Rank: 2

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

3^#

發表於 2020-8-22 00:51 | 顯示全部帖子

回復 18# qaqa3296
紅色部分是你的搜尋目標嗎? 如果是你可以用關鍵字篩選比較簡單如果結果不是你要的你可以把 "" & x & "*" 改成你要的方式
Public Sub 模糊篩選()
Range(Cells(2, 1), Cells(2, 4).End(xlDown)).Font.Color = RGB(255, 0, 0)
Application.ScreenUpdating = False
G = True
Sheets(3).Select
Sheets(3).Range(Cells(1, 6), Cells(1, 9).End(xlDown)).Clear
Sheets(2).Select
For K = 2 To Cells(2, 5).End(xlDown).Row
x = Cells(K, 5)
For i = 2 To Cells(2, 3).End(xlDown).Row '依條件篩選

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

      If G = True Then
         Range(Cells(1, 1), Cells(1, 4).End(xlDown)).Copy Sheets(3).Cells(1, 6)
         G = False
      Else
         Range(Cells(2, 1), Cells(2, 4).End(xlDown)).Copy Sheets(3).Cells(1, 6).End(xlDown).Offset(1, 0)
      End If
      Cells(2, 3).AutoFilter
Exit For
Next i
Next K
Sheets(3).Select
Range(Cells(2, 6), Cells(2, 9).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

4^#

發表於 2020-8-22 12:18 | 顯示全部帖子

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

回復 23# qaqa3296
我用正常ㄚ只是這速度比較慢沒有像大大們是在記憶體裡面執行的快還是這不是你要的?

javascript:;

javascript:;

javascript:;

javascript:;

javascript:;

2.png (102 KB)

3png.png (110.93 KB)

4.png (98.25 KB)

1.png (110.9 KB)

列出更多資料.rar (19.82 KB)

TOP

軒云熊

中學生 Rank: 2

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

5^#

發表於 2020-8-22 21:47 | 顯示全部帖子

回復 26# qaqa3296

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


javascript:;

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

TOP

軒云熊

中學生 Rank: 2

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

6^#

發表於 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

軒云熊

中學生 Rank: 2

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

7^#

發表於 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

8^#

發表於 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

軒云熊

中學生 Rank: 2

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

9^#

發表於 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

軒云熊

中學生 Rank: 2

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

10^#

發表於 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

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

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

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