標題:
請問 VBA 程式要如何修改 ，才能讓模糊條件比對完整條件，並刪除不出現在結果工作表
[打印本頁]
作者:
jeffrey628litw
時間:
2019-12-18 15:59
標題:
請問 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裡面，
[attach]31561[/attach]
然後按下右上紫色按鈕 查詢[未比對到]編號
2.比對工作表 "比對後重複清單" DORMAN 761-5104／HAKKO HLK1071
然後 HAKKO HLK1071產生在C欄
[attach]31562[/attach]
3.在每次比對後新產生的工作表 Sheet 消失。
[attach]31563[/attach]
檔案下載：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
時間:
2019-12-18 17:46
更正一下2.的結果
2.比對工作表 "比對後重複清單" DORMAN 761-5104／HAKKO HLK1071
然後 DORMAN 761-5104／HAKKO HLK1071
產生在C欄
作者:
jeffrey628litw
時間:
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
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)
