如何對特定欄進行篩選和替代資料 - Excel程式區

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

[發問] 如何對特定欄進行篩選和替代資料

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2013-5-26 13:35 | 顯示全部帖子

回復 1# luke

Option Explicit
Dim D As Object, DRng As Range
Sub 篩選()
資料篩選
With Sheet1.Range("L1")
.CurrentRegion = ""
If D.Count = 0 Then Exit Sub
.Resize(D.Count, 3) = Application.Transpose(Application.Transpose(D.ITEMS))
.CurrentRegion.Sort .Cells(1)
End With
End Sub
Sub 替代()
Dim Rng As Range, R As Range, E As Range, C As Range
資料篩選
Application.ScreenUpdating = False
With Sheet1
.Range("C:C").Value = .Range("C:C").Value '去除"'"字串'L1 多一個
Set Rng = .Range("L1").CurrentRegion
For Each R In Rng.Columns(2).Cells 'M欄的儲存格
If DRng.Find(R.Offset(, 1), lookat:=xlWhole) Is Nothing And Application.CountIf(.[B:B], R.Offset(, 1)) > 0 Then
'N欄資料中, 有與B欄非黃底儲存格的資料相同時就停止執行VBA-> 'N欄的字串在[篩選資料的儲存格]中比對不到, 且[B:B]中有此字串
With .Range("B:B")
.Replace R.Offset(, 1), "=XXX", xlWhole
With .SpecialCells(xlCellTypeFormulas, xlErrors)
.Value = R.Offset(, 1)
.Select
End With
End With
MsgBox R.Offset(, 1) & " 有重複值."
End
End If
With .Range("C:C")
.Replace R.Value, "=XXX", xlWhole
With .SpecialCells(xlCellTypeFormulas, xlErrors)
.Value = R
For Each E In .Areas
For Each C In E.Cells
If C.Offset(, -1) = R.Offset(, -1) Then C.Offset(, -1) = R.Offset(, 1)
Next
Next
End With
End With
Next
End With
Application.ScreenUpdating = True
End Sub
Private Sub 資料篩選()
Dim R As Range
Set D = CreateObject("SCRIPTING.DICTIONARY")
With Sheet1
For Each R In .Range("B1", .Cells(.Rows.Count, "B").End(xlUp))
If R <> "" And R.Cells(1, 2) <> "" Then
D(R & R.Cells(1, 2)) = Array(R, R.Cells(1, 2), R) '存入字典物件: 篩選的資料
If DRng Is Nothing Then '篩選資料的儲存格
Set DRng = R
Else
Set DRng = Union(R, DRng)
End If
End If
Next
End With
End Sub