- 帖子
- 2035
- 主題
- 24
- 精華
- 0
- 積分
- 2031
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office2010
- 閱讀權限
- 100
- 性別
- 男
- 註冊時間
- 2012-3-22
- 最後登錄
- 2024-2-1
|
6#
發表於 2016-7-22 17:06
| 只看該作者
回復 5# Michelle-W - Sub Ex()
- Dim rng As Range, dic As Object
- Dim r As Long, txt As String
-
- r = [A2].End(xlDown).Row
- Range("$A$1:$G$" & r).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlYes
-
- Set dic = CreateObject("scripting.dictionary")
- For Each rng In Range("A2", [A2].End(xlDown))
- If Not dic.exists(CStr(rng.Value)) Then dic(CStr(rng.Value)) = ""
- If rng.Offset(, 2) <> "" Or rng.Offset(, 3) <> "" Or rng.Offset(, 4) <> "" Or rng.Offset(, 5) <> "" Or rng.Offset(, 6) <> "" Then
- txt = Left(rng.Offset(, 2) & " ", 10) & Left(rng.Offset(, 3) & " ", 10) & _
- Left(rng.Offset(, 4) & " ", 10) & Left(rng.Offset(, 5) & " ", 10) & Left(rng.Offset(, 6) & " ", 10)
- Else
- txt = ""
- End If
-
- If txt <> "" Then dic(CStr(rng.Value)) = txt
- Next
-
- For r = Range("A2").End(xlDown).Row To 2 Step -1
- If Cells(r, 3) <> "" Or Cells(r, 4) <> "" Or Cells(r, 5) <> "" Or Cells(r, 6) <> "" Or Cells(r, 7) <> "" Then
- txt = Left(Cells(r, 3) & " ", 10) & Left(Cells(r, 4) & " ", 10) & _
- Left(Cells(r, 5) & " ", 10) & Left(Cells(r, 6) & " ", 10) & Left(Cells(r, 7) & " ", 10)
- Else
- txt = ""
- End If
- If txt <> dic(CStr(Cells(r, 1).Value)) Then Rows(r).EntireRow.Delete
- Next
- End Sub
|
|
發表於 2016-7-23 11:25
| 
