麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 列出更多的對應資料 [打印本頁]

作者: qaqa3296 時間: 2020-8-18 21:32 標題: 列出更多的對應資料

本帖最後由 qaqa3296 於 2020-8-18 21:42 編輯

要將"目標"的資料依序去尋找"庫存"內的資料(以"規格"進行模糊比對)並在"成果"列出全部對應的資料

現在是用笨方法用函數去寫，等待列出資料後再貼到成果。(人工代價太大了，也非常吃系統資源?電腦太慢了)
庫存內還有同規格不同料號的爛帳，庫存資料約有10000筆

感覺可以用VBA寫，但沒有頭緒，想問各位達人有沒有更合適的方式

目前編碼原則(英文字母)**-(英文字母)***
改版(英文字母)**-(英文字母)***-(英文字母區分版本)

其他沒有符合編碼原則的資料我自己手動找查，希望各位達人幫忙，減少工作時間
附上一個範例，笨方法也在目標內，高手請直接剔除即可。
謝謝

補充說明：不要以品名為基準查詢，重複與多於資料太多沒有參考價值
例如：鋁擠型，這千變萬化

作者: n7822123 時間: 2020-8-19 03:32

本帖最後由 n7822123 於 2020-8-19 03:46 編輯

回復 1# qaqa3296

對於VBA來說，這是 piece of cake

按黃色查詢按鈕即可!

程式如下

Sub 模糊查詢()
Dim Rg As Range, Addr0$, R1&
[K:N].ClearContents
With [庫存!C:C]
Set Rg = .Find([J2] & "*", , , xlWhole)
If Not Rg Is Nothing Then Addr0 = Rg.Address
Do While Not Rg Is Nothing
      R1 = R1 + 1
      Rg.Resize(, 4).Offset(, -2).Copy Cells(R1, "K")
      Set Rg = .FindNext(Rg)
      If Rg.Address = Addr0 Then Exit Do
Loop
End With
End Sub

檔案如下

[attach]32415[/attach]

作者: hcm19522 時間: 2020-8-19 09:55

{=INDEX(庫存!A:A,SMALL(IF(ISNUMBER(FIND($J$2,庫存!$C$2:$C$45)),ROW($2:$45),99),ROW(A1)))&""

作者: 准提部林 時間: 2020-8-19 11:20

尋找目標只有一個, 用篩選再貼即可

作者: qaqa3296 時間: 2020-8-19 20:01

看到各位大大的回復，才發現我說得不夠清楚，真是抱歉

[attach]32416[/attach]
1.如何對規格只取要的關鍵字，想想建個輔助查詢欄"LEFT函數"，還是有辦法剔除第二的"-"後面的資料?(想不出有更好的辦法，內容很雜亂)
2.輔助欄有些是空白如何列出需要的資料?
3.批次將輔助欄全部都查詢庫存，然後列到"成果"。
4.實際狀況是無法用品名去篩選資料的，大約500筆都是相同品名，但很多都是我不需要的資料

[attach]32417[/attach]
希望最後得到結果。

感謝各位大大幫忙

作者: jcchiang 時間: 2020-8-20 09:35

回復 5# qaqa3296

把龍大的程式修改一下
依需求直接將Left放入程式中
規格空白只好用品號查詢
執行結果與所需相符

Sub 模糊查詢()
Dim Rg As Range, Addr0$, R1&
[K:N].ClearContents
[K1:N1] = Array("品號", "品名", "規格", "數量")
R1 = 1
With [庫存!A:C]
For Each a In Sheets("目標").Range([a2], [a2].End(4))
   If a.Offset(, 2) <> "" Then
      Set Rg = .Find(Left(a.Offset(, 2), 8) & "*", , , xlWhole)
   Else
      Set Rg = .Find(a, , , xlWhole)
   End If
   If Not Rg Is Nothing Then Addr0 = Rg.Address
   Do While Not Rg Is Nothing
      R1 = R1 + 1
      If Rg.Column = 3 Then
         Rg.Resize(, 4).Offset(, -2).Copy Cells(R1, "K")
      Else
         Rg.Resize(, 4).Copy Cells(R1, "K")
      End If
      Set Rg = .FindNext(Rg)
      If Rg.Address = Addr0 Then Exit Do
   Loop
Next
End With
End Sub

作者: ikboy 時間: 2020-8-20 12:19

刪去公式,使用VBA會更快：

Sub zz()
Dim a, d As Object, b(), n&
a = Sheets(1).Range("a2:d" & Sheets(1).[a1048576].End(3).Row)
Set d = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
.Pattern = "-\w$"
For i = 1 To UBound(a)
If Len(a(i, 3)) = 0 Then a(i, 3) = a(i, 1)
k = a(i, 3)
a(i, 3) = .Replace(k, "")
d(a(i, 3)) = ""
Next
k = Join(d.keys, "|")
.Pattern = k
a = Sheets(2).[a1].CurrentRegion
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 2 To UBound(a)
If Len(a(i, 3)) > 0 Then k = a(i, 3) Else k = a(i, 1)
If .test(k) Then
n = n + 1
For j = 1 To UBound(a, 2)
b(n, j) = a(i, j)
Next
End If
Next
Sheets(3).[a1].CurrentRegion.Offset(1).Clear
Sheets(3).[a2].Resize(n, 4) = b
End With
End Sub

複製代碼

作者: 准提部林 時間: 2020-8-20 21:12

簡化不了,
Sub TEST()
Dim Arr, xD, i&, j%, N&, T$, V%
Set xD = CreateObject("scripting.dictionary")
Arr = Range([目標!C1], [目標!A65536].End(xlUp))
For i = 2 To UBound(Arr)
For j = 1 To 3 Step 2
      T = Arr(i, j):  If T <> "" Then xD(T) = 1
      If T Like "*-*-*" Then xD(Left(T, InStrRev(T, "-") - 1)) = 1
Next j
Next i
Arr = Range([庫存!D1], [庫存!A65536].End(xlUp))
For i = 2 To UBound(Arr)
For j = 1 To 3 Step 2
      T = Arr(i, j):  V = V + xD(T)
      If T Like "*-*-*" Then V = V + xD(Left(T, InStrRev(T, "-") - 1))
Next j
If V = 0 Then GoTo 101
N = N + 1: V = 0
For j = 1 To 4: Arr(N, j) = Arr(i, j): Next
101: Next i
[成果!A2:A6000].ClearContents
If N > 0 Then [成果!A2:D2].Resize(N) = Arr
End Sub

============================

作者: qaqa3296 時間: 2020-8-20 23:25

本帖最後由 qaqa3296 於 2020-8-20 23:34 編輯

感謝n7822123大大回復

這個問題最大的問題是取資料的方式

jcchiang大大的程式效果真好，除了沒辦法應付格子內有多餘的空白

ikboy大大會缺少資料，想請問你的程式思路是如何運作(沒辦法應付格子內有多餘的空白)
.Pattern = "-\w$"
k = Join(d.keys, "|")
作用是什麼呢?

准提部林大大也有缺少資料，想請問你的程式思路是如何運作(可以應付格子內有多餘的空白)
看起來是剔除第二的"-"後面的資料，但不太確定，學習中

回復軒云熊，都要列出

如果想在規格內(不是空白)，沒有找到任何資料，則將字體變紅當作提醒該如何修改?

作者: n7822123 時間: 2020-8-21 04:10

回復 9# qaqa3296

什麼叫做 "格子內有多餘的空白"，請講明白一點

作者: jcchiang 時間: 2020-8-21 07:56

本帖最後由 jcchiang 於 2020-8-21 07:59 編輯

回復 9# qaqa3296

如果是字串左右的空格,可使用Trim去除
Trim：刪除字串左、右兩端空白
Set Rg = .Find(Left(Trim(a.Offset(, 2)), 8) & "*", , , xlWhole)

作者: ikboy 時間: 2020-8-21 10:02

回復 9# qaqa3296

Sub zz()
Dim a, d As Object, b, n&
a = Sheets(1).Range("a2:d" & Sheets(1).[a1048576].End(3).Row)
Set d = CreateObject("scripting.dictionary")
With CreateObject("vbscript.regexp")
.Pattern = "[-\.\s]+"
.Global = True
For i = 1 To UBound(a)
If Len(a(i, 3)) = 0 Then a(i, 3) = Trim(a(i, 1))
a(i, 3) = Trim(a(i, 3))
k = Split(.Replace(a(i, 3), "|"), "|")
If UBound(k) > 0 Then k = k(0) & "-" & k(1) Else k = a(i, 3)
d(k) = ""
Next
k = Join(d.keys, "|")
.Pattern = k
a = Sheets(2).[a1].CurrentRegion
b = a: n = 1
For i = 2 To UBound(a)
If Len(a(i, 3)) > 0 Then k = a(i, 3) Else k = a(i, 1)
If .TEST(k) Then
n = n + 1
For j = 1 To UBound(a, 2)
b(n, j) = a(i, j)
Next
End If
Next
Workbooks.Add 1
[a1].Resize(n, 4) = b
End With
End Sub

複製代碼

作者: 准提部林 時間: 2020-8-21 10:06

回復 9# qaqa3296

不了解少資料是何意???
根據描述, 將規格 231-215-??? 第三字節去除, 做為另一比對條件,
文字前後若含有空白字元, 套一個TRIM(ARR(i,3)) 即可~~
100-1001.3.V1 這個是否還要取出 100-1001 做為條件,
多列出幾個不同型式的規格文字, 及其截取規則~~~

或者, 規格的前8碼為固定共用, 之後的為變化形, 都視為相同???

作者: 軒云熊 時間: 2020-8-21 18:09

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

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

javascript:;

作者: qaqa3296 時間: 2020-8-21 20:54

本帖最後由 qaqa3296 於 2020-8-21 20:58 編輯

回復n7822123
如jcchiang所說是兩側字串空格

感謝jcchiang補充新的語法

我取得資料時，規格欄被當作備註，打了一堆內容，刪掉那些訊息，則出現兩側字串空格最為常見，原本想說是不是要先用VLOOKUP去更新規格的內容，讓資料不會因人工打得錯誤多了空白等等..

看來也要更新一下思考模式了

回復准提部林
我一開始沒有注意到還有其他規格，如准提部林猜測的一樣

剛剛用LEN函數檢查一下

三個字節"-"四個字節做為條件效果，應該可以得到更理想的資料，再來才是取8碼，8碼以下的將會列出大量多餘資料，所以不需再建立新的規則，就改程式6~8碼輪流用即可

感謝各位大大的幫忙，有學到新的事物，覺得開心

作者: n7822123 時間: 2020-8-21 22:40

本帖最後由 n7822123 於 2020-8-21 22:54 編輯

回復 15# qaqa3296

你的"模糊比對" 規則真複雜，6~8碼輪流用?

什麼時候用6碼模糊比對，什麼時候用8碼模糊比對? 有沒有7碼比對?

寫程式講究 "邏輯"，你邏輯給的不清不楚，別人只能瞎子摸象!

如准大所說，你應該把"所有" 規格的格式通通列出來，並用顏色區分，要以哪些字元來"模糊比對"

不然以你的"文字敘述" 邏輯，會沒完沒了 ! 下面這句話，說實話，我就真的看不懂!!!

三個字節"-"四個字節做為條件效果，應該可以得到更理想的資料

舉例來說，下面紅色部分是要模糊比對的部分，紅色部分一樣則視為一樣

我隨便列2種，請你把"所有"格式列出，如下參考

A02-A001-E

99-A001-A

作者: 軒云熊 時間: 2020-8-21 23:20

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

作者: qaqa3296 時間: 2020-8-22 00:29

本帖最後由 qaqa3296 於 2020-8-22 00:32 編輯

回復 16# n7822123

說的模模糊糊真的很抱歉

附上圖片
[attach]32427[/attach]

最上面那些很細，可能會列出過多意想不到的資料。

作者: 軒云熊 時間: 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

作者: n7822123 時間: 2020-8-22 03:12

本帖最後由 n7822123 於 2020-8-22 03:21 編輯

回復 18# qaqa3296

確定就這4種格式摟?  就用你這4種格式進行模糊比對~

如果要添加其他格式在說，我想你看了我的程式也可以自己改了

這裡很多人都可以幫你完成，只要你邏輯敘述夠清楚!

簡單的東西沒必要搞複雜，我的程式邏輯如下

1.依4種格式的規格欄位去查詢庫存，進行模糊比對
2. 規格欄位若有空白字元，則移除空白字元再比對
3.若非此4種格式，則依品號抓資料(單筆)，不模糊比對
4.查詢的資料列到工作表"成果"

程式如下

Sub 模糊查詢()
Dim Rg As Range, 查找範圍 As Range, 此表 As Object
Dim Arr, R&, Key$, MD$, Csft&, K2$, Addr0$, R1&
[成果!A1].CurrentRegion.Offset(1).ClearContents
Arr = Range([D1], [A1].End(4))
Set 此表 = ActiveSheet: Sheets("成果").Activate
R1 = 1: [A1:D1] = Array("品號", "品名", "規格", "數量")
For R = 2 To UBound(Arr)
  MD = Replace(Arr(R, 3), " ", "") '移除空白(不管在哪個位置)
  Key = ""
  If MD Like "####*" Then Key = Left(MD, 4)
  If MD Like "[A-Z]####*" Then Key = Left(MD, 5)
  If MD Like "###-####*" Then Key = Left(MD, 8)
  If MD Like "[A-Z]##-[A-Z]###*" Then Key = Left(MD, 8)
  If Key <> "" Then  '若規格符合上述4種格式，則模糊查詢
Set 查找範圍 = [庫存!C:C]: Csft = -2: K2 = "*"
  Else '若規格不符合上述4種格式，改查品號(僅單筆)
Set 查找範圍 = [庫存!A:A]: Csft = 0: K2 = "": Key = Arr(R, 1)
  End If
  With 查找範圍
Set Rg = .Find(Key & K2, , , xlWhole)
   If Not Rg Is Nothing Then Addr0 = Rg.Address
   Do While Not Rg Is Nothing
      R1 = R1 + 1
      Rg.Resize(, 4).Offset(, Csft).Copy Cells(R1, "A")
      Set Rg = .FindNext(Rg)
      If Rg.Address = Addr0 Then Exit Do
   Loop
  End With
Next R
End Sub

檔案如下

[attach]32429[/attach]

作者: 准提部林 時間: 2020-8-22 10:09

這種文字比對太費周折,
看看是否如下規則, 若有其它, 再補充
[attach]32430[/attach]

可能沒空幫忙寫~~

作者: qaqa3296 時間: 2020-8-22 11:08

回復軒云熊你的程式不知是電腦太慢還是...? 當掉了

回復n7822123
程式真的是淺顯易懂超級入門

定義與修改真的很方便，也讓我了解到原來可以定義可以到如此細膩簡單

程式已達到需求。

回復准提部林
編碼原則正確，阿龍的程式已符合需求，如需其它定義，也能自行修改加入新的編碼原則

資料處理也不是想要一步登天，能大大減少反覆的動作，縮短時間就很棒了，覺得有學到東西

作者: qaqa3296 時間: 2020-8-22 12:07

回復 12# ikboy

感謝ikboy回復

例
6219-1未將6219列出
8011則列出錯誤的A8011

沒什麼大錯誤，只因編碼原則複雜，程式效果可以接受

研究程式中

阿龍程式已達到需求感謝幫忙。

作者: 軒云熊 時間: 2020-8-22 12:18

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

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

javascript:;

javascript:;

javascript:;

javascript:;

javascript:;

作者: 准提部林 時間: 2020-8-22 15:03

本帖最後由准提部林於 2020-8-22 15:05 編輯

測試資料太少, 無法多做驗證:
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 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 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 xS & "-" Like "####[-.]*" Then TT = Left(xS, 4)
If xS & "A" Like "####[A-Z]*" Then TT = Left(xS, 4)
If xS & "-" Like "?????[-.]*" Then TT = Left(xS, 5)
If xS & "-" Like "???-????[-.]*" Then TT = Left(xS, 8)
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

'全部貼入模組===============================================

作者: qaqa3296 時間: 2020-8-22 17:05

回復 25# 准提部林

程式執行過後，目標規格內必須嚴格遵照編碼原則，只要有不符合就會列出大量不符合編碼原則的資料? 太嚴苛了!?

附上測試檔案

回復軒云熊

提供的模擬檔只用於測試尋找。
實際規格內有大量的資訊與項目(沒有規律的型號文字說明等等...把規格當備註打!?)

利用編碼原則從中提取我要的訊息項目。所以我也不知哪裡出錯?

作者: 准提部林 時間: 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

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

作者: qaqa3296 時間: 2020-8-22 21:22

回復 27# 准提部林

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

作者: 軒云熊 時間: 2020-8-22 21:47

回復 26# qaqa3296

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


javascript:;

作者: qaqa3296 時間: 2020-8-22 22:59

回復 29# 軒云熊

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

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

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

作者: n7822123 時間: 2020-8-22 23:12

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

回復 29# 軒云熊

你可以繼續努力~~

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

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

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

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

作者: 軒云熊 時間: 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:;

作者: 軒云熊 時間: 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

作者: qaqa3296 時間: 2020-8-23 12:21

回復 33# 軒云熊

感謝軒云熊改進程式碼

資料還差一些

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

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

作者: 軒云熊 時間: 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

作者: qaqa3296 時間: 2020-8-25 20:44

回復 35# 軒云熊

目前測試

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

作者: 軒云熊 時間: 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

作者: 軒云熊 時間: 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

作者: 軒云熊 時間: 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

作者: qaqa3296 時間: 2020-8-25 23:55

回復 38# 軒云熊

程式思路走偏了。

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

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

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

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

算是互相學習吧

作者: 軒云熊 時間: 2020-8-26 17:45

回復 40# qaqa3296
你有試過我給你的最後一個修改後的嗎? 我剛才測試一下是可以的
我的思路是規格沒有就找品名如果品名在沒有就找品號不知這樣的方向是不是對的但是與準大的比對結果是一樣的
如果還有不正確的地方請你告訴我希望你能夠給我一個機會可以學習 ^_^

作者: 軒云熊 時間: 2020-8-26 18:38

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

回復 40# qaqa3296

剛才測試一下如果品號跟規格為空白只找品名如果是英文開頭準大的是會顯示
如果是中文開頭但品號跟規格為空白不會顯示唯一不同的地方在這
目前看到是這樣但我不知道是不是你要的

作者: qaqa3296 時間: 2020-8-26 20:11

回復 41# 軒云熊

我的思路是規格沒有就找品名如果品名再沒有就找品號不知這樣的方向是不是對的但是與準大的比對結果是一樣的
如果還有不正確的地方請你告訴我希望你能夠給我一個機會可以學習 ^_^

不要找品名，直接跳過，應該就可以了。就達到我當初的需求。

放上結果檔

作者: 軒云熊 時間: 2020-8-30 16:38

回復 43# qaqa3296

沒辦法還是有差格式太複雜我投降了.. 不過還是把檔案放上來你看看吧 >"<

javascript:;

作者: 軒云熊 時間: 2020-8-30 17:14

結論是...不能用篩選...呵呵..

作者: 軒云熊 時間: 2020-8-30 22:22

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

回復 43# qaqa3296
這是用先比對然後再比對結果與尋找範圍的相似度最低的再篩選但還是有差...我把檔案放上來你看一下...>"< 真的 ...沒辦法了..
會多M00027 煞車 6864 32 跟 M00025 車架 6844 0 因為裡面有相似度的問題..

javascript:;

作者: qaqa3296 時間: 2020-8-31 23:00

回復 46# 軒云熊

抱歉我的骨董電腦跑不動你的程式碼(96年買的 13年了)

庫存資料一多，每次案都當掉，無法幫你測試了...

你盡力了，我的電腦也盡力了...

作者: 軒云熊 時間: 2020-9-1 19:43

本帖最後由軒云熊於 2020-9-1 19:52 編輯

回復 47# qaqa3296
抱歉沒有整理就直接上傳麻煩你在幫我測試一次我想知道行不行真的跑不動就算了.. >"<

javascript:;

作者: qaqa3296 時間: 2020-9-2 00:04

回復 48# 軒云熊

測試過程有時會出現
執行階段錯誤91:
沒有設定物件變數或With區塊變數
錯誤範圍
If ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count <> 1 _
Or ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Areas.Count <> 1 Then
但觸發條件不明

有時不知再讀什麼一直跑好多分鐘都沒結束....觸發條件不明

我才剛開始學習，研究你的程式看很久，測試出問題要幾小時。一個晚上就沒了..花太多時間找你程式的BUG

作者: 軒云熊 時間: 2020-9-2 18:27

回復 49# qaqa3296
那是判斷篩選結果是不是空值我找到 GBKEE 大大以前寫的方式  拜託你在有空的話幫我在試一次看看還會不會這樣
我也是新手希望我們可以互相學習  我也希望你不要測試的太晚有空再測試就好了我的想法是先確定邏輯沒有問題之後
再往字典加陣列的方向前進慢慢學習研究一步一步來如果真的不行再把問題提出來問大大們應該可以得到答案
前提是你願意花時間  陪我一起學習研究 >"<    真的很謝謝你願意幫我測試

javascript:;

作者: qaqa3296 時間: 2020-9-2 21:57

本帖最後由 qaqa3296 於 2020-9-2 22:04 編輯

回復 50# 軒云熊

有時這行會跳錯誤
Sheets(2).Cells(j, 1).AutoFilter 3, "=*" & F & "*", Operator:=xlOr, Criteria2:=F
不明原因

花了不少時間，測出一個奇怪結果檔
資料很單純，但是還是錯了?
但不知為什麼錯，被我玩壞了?

提醒一下，你程式內准大的比較，是舊的程式碼，那個有些小問題，如果你用那個當基準寫程式，可能會有多列資料的問題，他有再修正

我放的檔有更新了

作者: 軒云熊 時間: 2020-9-6 01:13

回復 51# qaqa3296
這是在修改後的還是有差一點有空的話幫我測試一下這次是用準大的規則加上拆字的方式不知道行不行 .麻煩你了...^^"

javascript:;

作者: 軒云熊 時間: 2020-9-6 18:03

回復 51# qaqa3296
這是陣列加 Function 的方式寫的應該會比較快一點點.

javascript:;

作者: 軒云熊 時間: 2020-9-6 22:11

本帖最後由軒云熊於 2020-9-6 22:21 編輯

回復 51# qaqa3296
剛才試了一下如果只搜尋這3個
A02532       R          252-1006
M00050       外胎
M00001       外框          100-1001
結果會變成這樣 ...這結果是否有錯誤 ?  外胎和外框  是只要有新舊的版本都要列出  還是要指定的品號列出一個?

javascript:;

javascript:;

作者: qaqa3296 時間: 2020-9-6 23:22

回復 54# 軒云熊

目標規格如果沒有資料，只需列出一項資料即可

錯誤：篩選規則2的資料會將篩選規則1資料列出

再次附上篩選規則圖[attach]32516[/attach]

如果只看輸出結果，我覺得程式效果已經很好了

畢竟是模糊尋找，接近要的效果就很棒了

作者: 軒云熊 時間: 2020-9-7 23:00

本帖最後由軒云熊於 2020-9-7 23:14 編輯

回復 55# qaqa3296
改好了麻煩你了有空再幫我測試一下看看有沒有錯誤
javascript:;

javascript:;

javascript:;

作者: 軒云熊 時間: 2020-9-8 10:18

回復 55# qaqa3296
剛才發現判斷有錯誤改了一下 ...有空幫我測試一下看看還有沒有錯誤的地方謝謝你

javascript:;

作者: qaqa3296 時間: 2020-9-8 23:34

回復 57# 軒云熊

你改用陣列寫了

資料呈現符合規則，可以接受

沒發現什麼問題

作者: 軒云熊 時間: 2020-9-9 17:34

本帖最後由軒云熊於 2020-9-9 17:42 編輯

回復 58# qaqa3296
謝謝你幫我測試其實那還是有問題就是會重複抓第3攔的資料
因為有時候第3攔是空白的有時候不是所以想了最笨的方式就是刪除重複但這不是一個好方式
不知道該如何判斷.. 不過還是謝謝你願意花時間幫我測試還有準大們的規則可以解決這個複雜的格式問題 ..
其實字典的其中一個特點是可以刪除重複但我不會用因為那不是那麼直觀不太好理解
準大的字典運用我也看不明白只是猜測應該是把 1,3 欄的資料放到字典裡利用變數跟符號紀錄字典位置
在抓出來比對但是如何判斷我就不太明白了...

作者: 准提部林 時間: 2020-9-10 09:57

回復 59# 軒云熊

dic--keys, items
keys--只會留獨一無二的"索引值", 所以不會重覆
items--可以容納任何型態內容, 變化較多, 但可從簡單的著手

其實很好理解, 多幾次練習即可,
單欄資料:
1) 取得a欄內容的唯一值
2) 計算a欄各唯一值的出現次數
兩欄資料:
1) 計算a欄各唯一值在b欄的合計數
2) 計算a欄各唯一值,且b欄符合某一條件的次數

作者: 軒云熊 時間: 2020-9-11 10:52

本帖最後由軒云熊於 2020-9-11 10:58 編輯

回復 60# 准提部林
請問準提大大能不能寫成程式這樣會較好理解位置的運作方式如果可以的話 ^^" 因為放到字典裡的資料位置
不太明白是如何指定單一資料取出來

作者: 准提部林 時間: 2020-9-11 12:44

回復 61# 軒云熊

論壇有很多例子可參考~~
或到這多學習, 有現成較新的帖子當參考:
http://club.excelhome.net/forum-2-1.html

作者: 軒云熊 時間: 2020-9-12 17:31

本帖最後由軒云熊於 2020-9-12 17:39 編輯

回復 62# 准提部林
謝謝準大的指導但這方式只是在字典裡刪除重複而已不過應該會比較快一點點字典判斷重複陣列不提取的方式還在努力...

Public Sub 陣列加Function加字典練習()
Application.ScreenUpdating = False
If [成果!A1] <> "" Then [成果!A1].CurrentRegion.Clear
Crr = [目標!A1].CurrentRegion
Brr = [庫存!A1].CurrentRegion
ReDim Drr(1 To UBound(Brr, 1), 1 To UBound(Brr, 2))
Set xD = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Crr)
A3 = 分割文字(Trim(Crr(i, 3)))
A1 = Trim(Crr(i, 1))
For N = 1 To UBound(Brr)
B3 = 分割文字(Trim(Brr(N, 3)))
B1 = Trim(Brr(N, 1))
If A1 Like B1 Or A3 Like B3 And A3 <> "" Then
xD(Brr(N, 1)) = Brr(N, 1)
End If
Next N
Next i
For E = 1 To UBound(Brr)
If Brr(E, 1) = xD(Brr(E, 1)) Then
G = G + 1
For F = 1 To UBound(Brr, 2)
Drr(G, F) = Brr(E, F)
Next F
End If
Next E
Erase Brr, Crr
[成果!A1].Resize(G, UBound(Drr, 2)) = ""
[成果!A1].Resize(G, UBound(Drr, 2)) = Drr
Erase Drr
Sheets(3).Activate
Cells(1, 1).Select
Application.ScreenUpdating = False
End Sub
'====================================================================
Public Function 分割文字(A3)
Drx = Array("-", ".")
A7 = "": A8 = ""
For A9 = LBound(Drx) To UBound(Drx)
For A0 = 1 To Len(A3)
If InStr(Mid(Right(A3, A0), 1, 1), Drx(A9)) Then
A8 = Mid(Right(A3, A0), 1, A0)
A7 = Mid(A3, 1, Len(A3) - Len(A8))
Exit For
End If
Next A0
Next A9
If A7 = "" Then A7 = A3
If A7 = "" Then Exit Function
If Left(A7, 4) Like "####" Then
X = Mid(A7, 1, 4)
ElseIf Left(A7, 5) Like "####[A-Z]" Then
X = Mid(A7, 1, 5)
ElseIf Left(A7, 5) Like "[A-Z]####" Then
X = Mid(A7, 1, 5)
ElseIf Left(A7, 8) Like "???-????" Then
X = Mid(A7, 1, 8)
End If
If X = "" Then X = A3
分割文字 = X
End Function

複製代碼

作者: qaqa3296 時間: 2020-9-13 12:30

回復 63# 軒云熊

測試一下
查詢33個資料，資料庫數7000

陣列練習加Function練習_1=>11秒
陣列加Function加字典練習=>4秒

資料列出相同

作者: Andy2483 時間: 2022-10-20 15:20

回復 1# qaqa3296

謝謝前輩發表此主題與範例
不論是否符合需求! 後學在此帖學到很多知識!
後學的陣列與字典練習心得註解如下:
Option Explicit
Sub TEST_1()
Dim Brr, Arr, c&, R&, V, Y, Z
Dim K$, P$, Q, S
'↑宣告變數
S = Timer
Sheets(3).[M2:P60000].ClearContents
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set V = CreateObject("Scripting.Dictionary")
'↑令Y,Z,V各是字典
Arr = Sheets(1).Range("A1:C" & Sheets(1).[A65536].End(3).Row)
'↑目標表陣列範圍
For R = 1 To UBound(Arr)
'↑外順迴圈把目標表規格拆解,重組為模糊比對關鍵字並倒入V字典
For c = 1 To UBound(Arr, 2)
'↑內順迴圈去除空白字元
   Arr(R, c) = Replace(Arr(R, c), " ", "")
Next
P = Arr(R, 3)
If P Like "*-*-*" Then
   P = Split(P, "-")(0) & "-" & Split(P, "-")(1)
   ElseIf P = "" Then
   '↑如果規格欄是空格就以A欄格與B欄格組為模糊比對關鍵字
      P = Arr(R, 1) & Arr(R, 2)
End If
V(P) = 1
'↑倒入V字典
P = ""
Next
Brr = Sheets(2).Range("D1:A" & Sheets(2).[A65536].End(3).Row)
'↑庫存表陣列範圍
For R = 1 To UBound(Brr)
'↑外順迴圈把庫存表規格拆解,重組再加入符號 "|" 與列數
',為模糊比對關鍵字並倒入Z字典
For c = 1 To UBound(Brr, 2)
   '↑內順迴圈去除空白字元
   Brr(R, c) = Replace(Brr(R, c), " ", "")
   P = P & Brr(R, c) & "|"
   '↑把每列4欄的資料用 "|" 串起來
Next
K = Brr(R, 3)
If K Like "*-*-*" Then
   K = Split(K, "-")(0) & "-" & Split(K, "-")(1)
   ElseIf K = "" Then
      K = Brr(R, 1) & Brr(R, 2)
End If
Z(K & "|" & R) = P  '@@
'↑重組再加入符號 "|" 與列數
P = ""
Next
For Each Q In Z.KEYS
If V(Split(Q, "|")(0)) = 1 Then
'↑用 "|" 拆解Z字典裡的key,字串在V字典找到,代表符合提取條件
   Y(Q) = Split(Z(Q), "|")
    '↑用Y字典裝符合條件的Z字典item資料  @@處
End If
Next
Arr = Application.Transpose(Application.Transpose(Y.items))
'↑將Y字典的 items 轉置兩次就是結果資料
Sheets(3).[M1].Resize(Y.Count, 4) = Arr
MsgBox Timer - S & "秒"
End Sub

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)