- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
6#
發表於 2013-9-1 15:05
| 只看該作者
回復 6# sillykin
試試看- Option Explicit
- Sub Ex()
- Dim Rng(1 To 3) As Range, i As Integer, E As Range
- With Sheets("Sheet1") ' "Sheet1" 工作表名稱
- .Cells.Interior.ColorIndex = xlNone
- Set Rng(1) = .Range("A:F").SpecialCells(xlCellTypeConstants) '資料庫
- .Range("G:G") = ""
- Set Rng(3) = Rng(1).Rows(1)
- For i = 3 To 5 'C欄、D欄、E欄位做為準則
- .Cells(1, .Columns.Count) = Rng(1).Cells(1, i) '欄位做為準則
- Rng(1).Columns(i).AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True '篩選不重複的資料
- Set Rng(2) = .Range(.Cells(2, .Columns.Count), .Cells(2, .Columns.Count).End(xlDown)) '篩選出的資料範圍
- For Each E In Rng(2)
- If Application.CountIf(Rng(1).Columns(i), E) > 1 Then ' 資料在資料庫裡的資料數大於1
- With Rng(1).Columns(i).Cells
- .Replace E, "=XXX", xlWhole '更改為錯誤值
- With .SpecialCells(xlCellTypeFormulas, xlErrors) '錯誤值的特殊範圍裡
- .Value = E '置回原來的資料
- Set Rng(3) = Union(Rng(3), .Cells) '加入範圍
- .Interior.Color = vbYellow
- .Offset(, Rng(1).Columns.Count + 1 - i) = "重覆請查核"
- End With
- End With
- End If
- Next
- Next
- .Cells(1, .Columns.Count).EntireColumn = ""
- Set Rng(3) = Application.Intersect(.Cells, Rng(3).EntireRow) '整合為整列
- End With
- With Sheets("Sheet2")
- .Cells.Clear
- Rng(3).Copy .Range("A1")
- .Cells.Interior.ColorIndex = xlNone
- .Cells.EntireColumn.AutoFit
- End With
- End Sub
|
|
發表於 2013-9-1 18:00
| 
