12
返回列表 上一主題 發帖

[發問] 這種重複值刪除的VBA該如何寫(2003)

terrykyo520

帖子
7 
主題
1 
精華
0 
積分
17 
點名
0  
作業系統
WIN7 
軟體版本
Office 2003 
閱讀權限
10 
性別
男 
註冊時間
2015-8-5 
最後登錄
2015-9-12 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2015-8-10 16:23 | 只看該作者

[發問] 這種重複值刪除的VBA該如何寫(2003)

EXCEL為2003版本
如果B列有重複就判斷C列是否也相同
不同則不刪除
B.C皆相同則刪除此行 舉例如下
    A     B    C
1  1   P1   B6
2  2   P1   B2
3  3   P1   B6
4  4   P2   B2
5  5   P5   B6

第2行的B為P1 與第1行的B值相同但C不同 不刪除
第3行的B與C和第1行的相同 故刪除
請問VBA該如何寫~謝謝
連刪除B欄重複值都寫不出來~...
例子圖
收藏 分享

Scott090

帖子
519 
主題
54 
精華
0 
積分
595 
點名
258  
作業系統
win 10 
軟體版本
[] 
閱讀權限
50 
性別
男 
註冊時間
2013-3-19 
最後登錄
2024-11-25 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章2015羊年全勤獎章
2#
發表於 2015-8-10 20:31 | 只看該作者
回復 1# terrykyo520


    試試看這個是否符合需要
  1. Sub Test0()
  2.     Dim H&
  3.     Range("A2").Select
  4.     H = [A1].End(xlDown).Row
  5.     Range("$A$1:$C$" & H).RemoveDuplicates Columns:=Array(2, 3), Header:=xlYes
  6. End Sub
複製代碼

TOP

terrykyo520

帖子
7 
主題
1 
精華
0 
積分
17 
點名
0  
作業系統
WIN7 
軟體版本
Office 2003 
閱讀權限
10 
性別
男 
註冊時間
2015-8-5 
最後登錄
2015-9-12 
3#
發表於 2015-8-10 21:03 | 只看該作者
回復 2# Scott090


RemoveDuplicates這只有2007以上版本才可用
我的版本是2003的
謝謝

TOP

Scott090

帖子
519 
主題
54 
精華
0 
積分
595 
點名
258  
作業系統
win 10 
軟體版本
[] 
閱讀權限
50 
性別
男 
註冊時間
2013-3-19 
最後登錄
2024-11-25 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章2015羊年全勤獎章
4#
發表於 2015-8-10 23:13 | 只看該作者
回復 3# terrykyo520


   這個應沒有版本的區別
  1. Sub Test1()
  2.     Dim i&, j&
  3.     Dim aa, bb
  4.    
  5.     i = [A1].End(xlDown).Row
  6.     aa = Range("A2:C" & i).Value
  7.     For i = 1 To UBound(aa) - 1
  8.         For j = i + 1 To UBound(aa)
  9.             If aa(j, 2) = aa(i, 2) And aa(j, 3) = aa(i, 3) Then
  10.                 aa(j, 1) = "": aa(j, 2) = "": aa(j, 3) = ""
  11.             End If
  12.         Next
  13.     Next
  14.     ReDim bb(UBound(aa), 3)
  15.     j = 0
  16.     For i = 1 To UBound(aa)
  17.         If aa(i, 1) <> "" Then
  18.             j = j + 1
  19.             bb(j, 1) = aa(i, 1): bb(j, 2) = aa(i, 2): bb(j, 3) = aa(i, 3)
  20.         End If
  21.     Next
  22.     Range("A2").Resize(UBound(aa), 3).Clear
  23.     Range("A2").Resize(UBound(bb), 3) = bb

  25. End Sub
複製代碼

TOP

terrykyo520

帖子
7 
主題
1 
精華
0 
積分
17 
點名
0  
作業系統
WIN7 
軟體版本
Office 2003 
閱讀權限
10 
性別
男 
註冊時間
2015-8-5 
最後登錄
2015-9-12 
5#
發表於 2015-8-11 11:48 | 只看該作者
本帖最後由 terrykyo520 於 2015-8-11 11:49 編輯

回復 4# Scott090
我套用下去結果怪怪的~會空一行又 再下一行A列的值跑到B去 B列的值跑到C列 C列的值不見
可否請幫我依這TEST的EXCEL下去看看呢~~謝謝教學~
想要執行後的結果如圖~左執行前~右為執行後

TEST.rar (1.59 KB)

TOP

Scott090

帖子
519 
主題
54 
精華
0 
積分
595 
點名
258  
作業系統
win 10 
軟體版本
[] 
閱讀權限
50 
性別
男 
註冊時間
2013-3-19 
最後登錄
2024-11-25 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章2015羊年全勤獎章
6#
發表於 2015-8-11 15:27 | 只看該作者
回復 5# terrykyo520


    請列一期望的結果表是什麼
這樣比較好處理

TOP

lpk187

帖子
552 
主題
3 
精華
0 
積分
578 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2024-7-9 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
7#
發表於 2015-8-11 18:14 | 只看該作者
回復 5# terrykyo520
試試！
  1. Public Sub ex()
  2. Dim ar()
  3. arr = Range("a2:C" & Cells(Rows.Count, 1).End(xlUp).Row)
  4. k = UBound(arr)
  5. For i = 1 To UBound(arr) - 1
  6.     For j = i + 1 To UBound(arr)
  7.         If arr(i, 1) = "" Or arr(j, 1) = "" Then GoTo 10
  8.         If arr(i, 2) & arr(i, 3) = arr(j, 2) & arr(j, 3) Then
  9.             arr(j, 1) = ""
  10.             arr(j, 2) = ""
  11.             arr(j, 3) = ""
  12.             k = k - 1
  13.         End If
  14. 10:
  15.     Next
  16. Next

  18. ReDim ar(1 To k, 1 To 3)
  19. k = 1
  20. For i = 1 To UBound(arr)
  21.     If arr(i, 1) <> "" Then
  22.         ar(k, 1) = arr(i, 1)
  23.         ar(k, 2) = arr(i, 2)
  24.         ar(k, 3) = arr(i, 3)
  25.         k = k + 1
  26.     End If
  27. Next
  28. Range("a2:C" & Cells(Rows.Count, 1).End(xlUp).Row).Clear
  29. [a2].Resize(UBound(ar), 3) = ar
  30. End Sub
複製代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
255  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-25 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
8#
發表於 2015-8-11 18:39 | 只看該作者
回復 1# terrykyo520
  1. Sub ex()
  2. Dim A As Range
  3. Set d = CreateObject("Scripting.Dictionary")
  4. For Each A In Range([B1], [B1].End(xlDown))
  5. If d.exists(A & A.Offset(, 1)) = False Then d(A & A.Offset(, 1)) = A.Offset(, -1).Resize(, 3).Value
  6. Next
  7. [A:C].ClearContents
  8. [A1].Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
  9. End Sub
複製代碼
學海無涯_不恥下問

TOP

Scott090

帖子
519 
主題
54 
精華
0 
積分
595 
點名
258  
作業系統
win 10 
軟體版本
[] 
閱讀權限
50 
性別
男 
註冊時間
2013-3-19 
最後登錄
2024-11-25 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章2015羊年全勤獎章
9#
發表於 2015-8-11 18:49 | 只看該作者
回復 5# terrykyo520


    答案跟你的右圖一樣
test1.rar (9.04 KB)

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
10#
發表於 2015-8-13 16:46 | 只看該作者
還有方法可試
  1. Option Explicit
  2. Sub Ex()
  3.     Dim R As Range, Rng As Range
  4.     With ActiveSheet.UsedRange
  5.         .Columns("b:c").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
  6.         For Each R In .Rows
  7.             If R.Height = 0 Then
  8.                 If Rng Is Nothing Then
  9.                     Set Rng = R
  10.                 Else
  11.                     Set Rng = Union(Rng, R)
  12.                 End If
  13.             End If
  14.         Next
  15.     End With
  16.     Application.DisplayAlerts = False
  17.     If Not Rng Is Nothing Then Rng.Delete
  18.     Application.DisplayAlerts = True
  19. End Sub
  20. Sub Ex1()
  21.     Dim Sh As Worksheet, wb As Workbook
  22.     Set Sh = ActiveSheet
  23.     Sh.Copy
  24.     Set wb = ActiveWorkbook
  25.     With wb.Sheets(1)
  26.         .UsedRange.Columns("b:c").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
  27.         Sh.UsedRange.Clear
  28.         .UsedRange.Copy Sh.Range("A1")
  29.         .Parent.Close False
  30.     End With
  31. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 慈悲沒有敵人，智慧不起煩惱。
12
返回列表 上一主題