返回列表下一主題上一主題發帖

[發問] 如何將篩選程式碼及刪除重複程式碼合併

lilizzzz

小學生 Rank: 1

帖子: 17
主題: 4
精華: 0
積分: 22
點名: 0
作業系統: windows10
軟體版本: windows10
閱讀權限: 10
性別: 男
註冊時間: 2020-11-18
最後登錄: 2022-1-12

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2020-11-27 11:28 | 只看該作者

[發問] 如何將篩選程式碼及刪除重複程式碼合併

各位先進大家好，

我利用錄製巨集(在從中修改)，篩選出我想要的資料表，另又撰寫另外一份，刪除重複值(並保留最新資料)的VBA

想請教，要如何將兩份程式碼合併，可以在篩選資料過程中，一並剔除重複資料(保留最新資料)，

以下是我的程式碼，懇請協助

Sub 產品種類及時間區間查詢()
'
Sheets("3P-INSPPROD").Range("A1:AK300000").AdvancedFilter Action:=xlFilterCopy _
      , CriteriaRange:=Range("A1:C3"), CopyToRange:=Range("A7:AK7") _
      , Unique:=False

ActiveWindow.SmallScroll Down:=-27
Cells.Select
Range("J21").Activate
With Selection.Font
      .Size = 14
      .Strikethrough = False
      .Superscript = False
      .Subscript = False
      .OutlineFont = False
      .Shadow = False
      .Underline = xlUnderlineStyleNone
      .TintAndShade = 0
End With
With Selection.Font
      .Name = "標楷體"
      .Size = 14
      .Strikethrough = False
      .Superscript = False
      .Subscript = False
      .OutlineFont = False
      .Shadow = False
      .Underline = xlUnderlineStyleNone
      .TintAndShade = 0
      .ThemeFont = xlThemeFontNone
End With
Range("E9").Select
End Sub

Sub 刪除重覆值()
'建立字典，把對象賦予dictionary，(等於判斷依據)
Set dic = CreateObject("scripting.dictionary")
'從A列最後一列開始進行篩選: step -1
'如果是從第一列開始會有刪除跳行情況，無法達成刪除重複效果
For i = Range("A65536").End(3).Row To 1 Step -1
'如果A欄數據已經存在字典中(等於重複了)則執行THEN
If dic.exists(Cells(i, "A").Value) Then
'刪除該列
Rows(i).Delete
Else
'若A欄數據未存於字典內，則將其加入字典
dic(Cells(i, "A").Value) = ""
End If
Next i
End Sub