麻辣家族討論版版 - Powered by Discuz! Board

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

複製代碼

.Range("C:C").Value = .Range("C:C").Value '去除"'"字串'L1 多一個

複製代碼

Sub 篩選()
Set d = CreateObject("Scripting.Dictionary")
With sheet1
For Each a In .Range(.[B1], .Cells(.Rows.Count, 2).End(xlUp))
If a.Interior.ColorIndex = 6 Then d(a.Value) = Array(a, a.Offset(, 1), a)
Next
With .Range("L1")
.CurrentRegion = ""
.Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
.Resize(d.Count, 3).Sort .Cells(1, 1), xlAscending, Header:=xlNo
End With
End With
End Sub
Sub 取代()
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With sheet1
With .Range("L1").CurrentRegion
For Each a In .Columns(1).Cells
d(a.Value) = a.Offset(, 2)
d1(a.Offset(, 2).Value) = a.Value
Next
End With
For Each a In .Range(.[B1], .Cells(.Rows.Count, 2).End(xlUp))
If d1.exists(a.Value) And a.Interior.ColorIndex <> 6 Then MsgBox "資料重複": Exit Sub
Next
For Each a In .Range(.[B1], .Cells(.Rows.Count, 2).End(xlUp))
If d.exists(a.Value) And a.Interior.ColorIndex = 6 Then a.Value = d(a.Value)
Next
MsgBox "取代完成"
End With
End Sub

複製代碼