返回列表 上一主題 發帖

請問 VBA 程式要如何修改 ,才能讓模糊條件比對完整條件,並刪除不出現在結果工作表

請問 VBA 程式要如何修改 ,才能讓模糊條件比對完整條件,並刪除不出現在結果工作表

本帖最後由 jeffrey628litw 於 2019-12-18 16:03 編輯

請問 VBA 程式要如何修改 ,才能讓模糊條件比對完整條件,並刪除不出現在結果工作表

請問 VBA  Module11  程式要如何修改,才能讓工作表  "設比對條件清單"  裡面  HAKKO HLK1071
能比對工作表  "比對後重複清單"    DORMAN 761-5104/HAKKO HLK1071

然後  HAKKO HLK1071產生在C欄,
在每次比對後新產生的工作表 Sheet  消失。

1.輸入HAKKO HLK1071  在 A欄 Partslink裡面,
圖片 1.jpg
2019-12-18 15:52

然後按下右上紫色按鈕   查詢[未比對到]編號

2.比對工作表  "比對後重複清單"    DORMAN 761-5104/HAKKO HLK1071
然後  HAKKO HLK1071產生在C欄
圖片 2.jpg
2019-12-18 15:54


3.在每次比對後新產生的工作表 Sheet  消失。
圖片 3.jpg
2019-12-18 15:56


檔案下載:https://cht.tw/h/qvba0

Module11 程式碼:

Sub 開始比對不重複()

   Dim t1
   
    t1 = Timer   '這是產生秒數的 MSG
   
   '==============================================================
   
    Sheets("比對後重複清單").Select
   
    ROW1 = Cells(Rows.Count, "C").End(3).Row
   
'下面3列程式是如果要撈出2欄以上資料需開放的程式碼

'   If ROW1 > 2 Then
'       Range(Cells(1, "C"), Cells(ROW1, "E")).Clear
'   End If

'==============================================================
   
    ROW1 = Cells(Rows.Count, "A").End(3).Row
   
    arr = Range("A2:A" & ROW1)
   
    ROW2 = Sheets("設比對條件清單").Cells(Rows.Count, "A").End(3).Row
   
  '如果要撈出2欄以上資料需開放的程式碼,2欄 Range("A1:A" & ROW2) 要改成 Range("A1:B" & ROW2)
   
    Sheets("設比對條件清單").Range("A1:A" & ROW2).AdvancedFilter _
        Action:=xlFilterCopy, CriteriaRange:=Range("A1:A" & ROW1), CopyToRange:=Range( _
        "C1:C1"), Unique:=False
        
        '上面的 "C1:C1" 為從資料庫撈出比對後資料,顯示在此工作表 C1:C1
   
    Columns("C:C").ColumnWidth = 28
    Columns("D:D").ColumnWidth = 16
   
   
    '==============================================================

    '以下是生成   不重複項目  的工作表
   
    Sheets.Add After:=Sheets(Sheets.Count)
    'Sheets(Sheets.Count).Name = "未比對到清單"

    Columns("A:A").ColumnWidth = 28
    Columns("B:B").ColumnWidth = 16
   
   
    Cells(1, 3).Formula = "● 此是[未比對到]清單"
    Cells(1, 3).Font.Color = RGB(43, 20, 134)
    Cells(1, 3).Font.Bold = True
    Cells(1, 6).Formula = "● 使用過後可刪除此工作表"
    Cells(1, 6).Font.Color = RGB(128, 13, 32)
    Cells(1, 6).Font.Bold = True
   
   
    Sheets("設比對條件清單").Range("A1:A" & ROW2).Copy Range("A1")
   
    For i = ROW2 To 2 Step -1
        
        For j = 1 To UBound(arr)
            If Cells(i, "A") Like arr(j, 1) Then
                Rows(i).Delete
                GoTo 1100
            End If
        Next
     
1100:
   
          Next
         
'==============================================================
         
         
'以下為讓產生  工作表   不重複項目     的A1儲存格產生名稱

With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With


'==============================================================


'以下為顯示VBA Run程式的時間

MsgBox "抓資料完成!  " & Chr(10) & "使用時間:" & Round(Timer - t1, 2) & " 秒" & Chr(10) & "未比對到的資料,共計有" & "  " & Application.CountA(ActiveSheet.Columns("A:A")) - 1 & "  " & "筆"

'MsgBox "抓資料完成!  " & Chr(10) & "使用時間:" & Round(Timer - t1, 2) & " 秒" 這是產生秒數的 MSG
  
'==============================================================
End Sub

更正一下2.的結果

2.比對工作表  "比對後重複清單"    DORMAN 761-5104/HAKKO HLK1071
然後  DORMAN 761-5104/HAKKO HLK1071

產生在C欄

TOP

回復 1# jeffrey628litw

爬文已經找到方法,提供給各位參考

Sub 過濾單一儲存格雙條件重複清單()

Dim Ar(32)

Sheets("設比對條件清單").Select
    Sheets("設比對條件清單").Name = "Sheet1"
   

Set d = CreateObject("Scripting.Dictionary")
With Sheet1

For Each a In .Range(.[A2], .[A101].End(xlUp))
  
  
  
  For i = 0 To 1
   Ar(i) = a.Offset(, i).Value
Next i
d(a & "") = Ar
  

Next
End With

Range("a1").Parent.Name = "設比對條件清單"

Sheets("比對後重複清單").Select
    Sheets("比對後重複清單").Name = "Sheet2"
   
   
   
   
With Sheet2




For Each a In .Range(.[D2], .[D101].End(xlUp))
    For Each ky In d.keys
       If InStr(a, ky) > 0 Then a.Offset(, -3).Resize(, 1) = d(ky): Exit For
    Next
Next

End With



Range("D2").Select
    Selection.AutoFill Destination:=Range("D2:D101"), Type:=xlFillDefault
    Range("D2:D101").Select
   
    Range("D2").Select
   
   

Range("a1").Parent.Name = "比對後重複清單"

End Sub

TOP

        靜思自在 : 發脾氣是短暫的發瘋。
返回列表 上一主題