請問 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裡面，

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

2.比對工作表 "比對後重複清單" DORMAN 761-5104／HAKKO HLK1071
然後 HAKKO HLK1071產生在C欄

3.在每次比對後新產生的工作表 Sheet 消失。

檔案下載：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

樓主熱帖

jeffrey628litw

中學生 Rank: 2

帖子: 228
主題: 62
精華: 0
積分: 364
點名: 20
作業系統: Win 10
軟體版本: Office 2007 & 2010
閱讀權限: 20
性別: 男
註冊時間: 2011-3-5
最後登錄: 2024-9-16

2011兔年全勤獎章

3^#

發表於 2019-12-20 09:55 | 只看該作者

回復 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

jeffrey628litw