Board logo

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

作者: 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會更快:
  1. Sub zz()
  2. Dim a, d As Object, b(), n&
  3. a = Sheets(1).Range("a2:d" & Sheets(1).[a1048576].End(3).Row)
  4. Set d = CreateObject("scripting.dictionary")
  5. With CreateObject("vbscript.regexp")
  6.     .Pattern = "-\w$"
  7.     For i = 1 To UBound(a)
  8.         If Len(a(i, 3)) = 0 Then a(i, 3) = a(i, 1)
  9.         k = a(i, 3)
  10.         a(i, 3) = .Replace(k, "")
  11.         d(a(i, 3)) = ""
  12.     Next
  13.     k = Join(d.keys, "|")
  14.     .Pattern = k
  15.     a = Sheets(2).[a1].CurrentRegion
  16.     ReDim b(1 To UBound(a), 1 To UBound(a, 2))
  17.     For i = 2 To UBound(a)
  18.         If Len(a(i, 3)) > 0 Then k = a(i, 3) Else k = a(i, 1)
  19.         If .test(k) Then
  20.              n = n + 1
  21.              For j = 1 To UBound(a, 2)
  22.                 b(n, j) = a(i, j)
  23.              Next
  24.         End If
  25.     Next
  26.     Sheets(3).[a1].CurrentRegion.Offset(1).Clear
  27.     Sheets(3).[a2].Resize(n, 4) = b
  28. End With
  29. 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
  1. Sub zz()
  2. Dim a, d As Object, b, n&
  3. a = Sheets(1).Range("a2:d" & Sheets(1).[a1048576].End(3).Row)
  4. Set d = CreateObject("scripting.dictionary")
  5. With CreateObject("vbscript.regexp")
  6.     .Pattern = "[-\.\s]+"
  7.     .Global = True
  8.     For i = 1 To UBound(a)
  9.         If Len(a(i, 3)) = 0 Then a(i, 3) = Trim(a(i, 1))
  10.         a(i, 3) = Trim(a(i, 3))
  11.         k = Split(.Replace(a(i, 3), "|"), "|")
  12.         If UBound(k) > 0 Then k = k(0) & "-" & k(1) Else k = a(i, 3)
  13.         d(k) = ""
  14.     Next
  15.     k = Join(d.keys, "|")
  16.     .Pattern = k
  17.     a = Sheets(2).[a1].CurrentRegion
  18.     b = a: n = 1
  19.     For i = 2 To UBound(a)
  20.         If Len(a(i, 3)) > 0 Then k = a(i, 3) Else k = a(i, 1)
  21.         If .TEST(k) Then
  22.              n = n + 1
  23.              For j = 1 To UBound(a, 2)
  24.                 b(n, j) = a(i, j)
  25.              Next
  26.         End If
  27.     Next
  28.     Workbooks.Add 1
  29.     [a1].Resize(n, 4) = b
  30. End With
  31. 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# 准提部林
謝謝準大的指導  但這方式  只是在字典裡刪除重複而已  不過應該會比較快一點點  字典判斷重複陣列不提取的方式還在努力...
  1. Public Sub 陣列加Function加字典練習()
  2. Application.ScreenUpdating = False
  3. If [成果!A1] <> "" Then [成果!A1].CurrentRegion.Clear
  4. Crr = [目標!A1].CurrentRegion
  5. Brr = [庫存!A1].CurrentRegion
  6. ReDim Drr(1 To UBound(Brr, 1), 1 To UBound(Brr, 2))
  7. Set xD = CreateObject("Scripting.Dictionary")
  8.     For i = 1 To UBound(Crr)
  9.         A3 = 分割文字(Trim(Crr(i, 3)))
  10.         A1 = Trim(Crr(i, 1))
  11.         For N = 1 To UBound(Brr)
  12.             B3 = 分割文字(Trim(Brr(N, 3)))
  13.             B1 = Trim(Brr(N, 1))
  14.             If A1 Like B1 Or A3 Like B3 And A3 <> "" Then
  15.                xD(Brr(N, 1)) = Brr(N, 1)
  16.             End If
  17.         Next N
  18.     Next i
  19.     For E = 1 To UBound(Brr)
  20.         If Brr(E, 1) = xD(Brr(E, 1)) Then
  21.             G = G + 1
  22.             For F = 1 To UBound(Brr, 2)
  23.                 Drr(G, F) = Brr(E, F)
  24.             Next F
  25.         End If
  26.     Next E
  27. Erase Brr, Crr
  28. [成果!A1].Resize(G, UBound(Drr, 2)) = ""
  29. [成果!A1].Resize(G, UBound(Drr, 2)) = Drr
  30. Erase Drr
  31. Sheets(3).Activate
  32. Cells(1, 1).Select
  33. Application.ScreenUpdating = False
  34. End Sub
  35. '====================================================================
  36. Public Function 分割文字(A3)
  37.     Drx = Array("-", ".")
  38.     A7 = "": A8 = ""
  39.     For A9 = LBound(Drx) To UBound(Drx)
  40.         For A0 = 1 To Len(A3)
  41.             If InStr(Mid(Right(A3, A0), 1, 1), Drx(A9)) Then
  42.                 A8 = Mid(Right(A3, A0), 1, A0)
  43.                 A7 = Mid(A3, 1, Len(A3) - Len(A8))
  44.             Exit For
  45.             End If
  46.         Next A0
  47.     Next A9
  48.     If A7 = "" Then A7 = A3
  49.     If A7 = "" Then Exit Function
  50.     If Left(A7, 4) Like "####" Then
  51.        X = Mid(A7, 1, 4)
  52.     ElseIf Left(A7, 5) Like "####[A-Z]" Then
  53.        X = Mid(A7, 1, 5)
  54.     ElseIf Left(A7, 5) Like "[A-Z]####" Then
  55.        X = Mid(A7, 1, 5)
  56.     ElseIf Left(A7, 8) Like "???-????" Then
  57.        X = Mid(A7, 1, 8)
  58.     End If
  59.     If X = "" Then X = A3
  60.     分割文字 = X
  61. End Function
複製代碼

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

回復 63# 軒云熊

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

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

資料列出相同




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