- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 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
|
|
發表於 2013-5-25 22:27
| 
