12
返回列表 上一主題 發帖

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

terrykyo520

帖子
7 
主題
1 
精華
0 
積分
17 
點名
0  
作業系統
WIN7 
軟體版本
Office 2003 
閱讀權限
10 
性別
男 
註冊時間
2015-8-5 
最後登錄
2015-9-12 
11# 跳轉到 »
發表於 2015-8-23 19:50 | 只看該作者
回復 8# lpk187
謝謝~可以耶~

請問這行的意思是
Cells(Rows.Count, 1).End(xlUp).Row

如果我的產品在第M列 地區在第Q列  資料總共到AD列
是要改成
arr = Range("a2:AD" & Cells(Rows.Count, 1).End(xlUp).Row)

要怎麼修改呢~謝謝

TOP

terrykyo520

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

OK可行耶
我只看得懂 Dim A As Range
剩下~好難

如果我的產品在第M列 地區在第Q列  資料總共到AD列
要怎麼修改呢~謝謝

TOP

terrykyo520

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


    謝謝幫忙~目前我無法下載檔案
    只能先說聲3Q~之後再下載看看寫法~~

TOP

lpk187

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

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
14#
發表於 2015-8-23 20:43 | 只看該作者
回復 12# terrykyo520

Cells(Rows.Count, 1).End(xlUp).Row是A欄的最後一格的列號，Rows.Count為所有的列號，1就是A欄
原來的欄數只有些3欄，所以寫的比較簡單，但是若資料數量很多時就不能如下面表示的寫法，
            arr(j, 1) = ""
            arr(j, 2) = ""
            arr(j, 3) = ""
            ...
            ....
            .......
            .......
            arr(j, X) = ""
這樣寫會累死的
所以必須多一個迴圈
  1. Public Sub ex()
  2. Dim ar()
  3. arr = Range("A2:AD" & 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, 13) & arr(I, 17) = arr(j, 13) & arr(j, 17) Then
  9.             For L = 1 To UBound(arr, 2)
  10.                 arr(j, L) = ""
  11.             Next
  12.             K = K - 1
  13.         End If
  14. 10:
  15.     Next
  16. Next

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

TOP

Scott090

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

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章論壇榮譽勳章論壇贊助勳章2015羊年全勤獎章熱烈參與勳章
15#
發表於 2015-8-23 22:21 | 只看該作者
回復 14# terrykyo520

請注意陣列起始位置 是 0 還是 1
加 Option base 1 是定義陣列從 1 開始

參照 4#

Option base 1   
Sub Test1()
    Dim i&, j&
    Dim aa, bb
   
    i = [A1].End(xlDown).Row
    aa = Range("A2:C" & i).Value
   For i = 1 To UBound(aa) - 1
.........

TOP

terrykyo520

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


這兩種也可以耶~好多方法
如果我的產品在第M列 地區在第Q列  資料總共到AD列
是要改成
Sub Ex()
    Dim R As Range, Rng As Range
    With ActiveSheet.UsedRange
        .Columns("M:Q").AdvancedFilter Action:=xlFilterInPlace, Unique:=True


Sub Ex1()
    Dim Sh As Worksheet, wb As Workbook
    Set Sh = ActiveSheet
    Sh.Copy
    Set wb = ActiveWorkbook
    With wb.Sheets(1)
        .UsedRange.Columns("M:Q").AdvancedFilter Action:=xlFilterInPlace, Unique:=True

改這兩邊嗎~TKS

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
17#
發表於 2016-10-7 12:15 | 只看該作者
不好意思借標題問一下,

有試著將lpk187大的程式碼略做修改,

因為對VBA真的還是新手程度,所以修改的部份做得很不好,

先簡述目前希望達到的效果:
1.若兩橫列的J欄數值不同,L欄數值相同,
則僅清除其中一橫列的L欄數值,兩橫列均不刪除.

2.跟上述規則類似,
若兩橫列的J欄數值相同,L欄數值不同,
則僅清除其中一橫列的J欄數值,兩橫列均不刪除.

3.若兩橫列的J欄數值及L欄數值均為空白,
則兩橫列均刪除.
修改後程式碼如下:
  1. Public Sub extwo()
  2. Dim ar()
  3. Range("c2").Resize(Cells(Rows.Count, 3).End(xlUp).Row, 1).Select
  4. Selection.Resize(Selection.Rows.Count - 1, 1).Select
  5. Selection.Copy Range("a2")

  7. arr = Range("A2:AD" & Cells(Rows.Count, 1).End(xlUp).Row)
  8. K = UBound(arr)
  9. For i = 1 To UBound(arr) - 1
  10.     For j = i + 1 To UBound(arr)
  11.         If arr(i, 1) = "" Or arr(j, 1) = "" Then GoTo 10
  12.         If arr(i, 11) & arr(i, 13) = arr(j, 11) & arr(j, 13) Then
  13.             For L = 1 To UBound(arr, 2)
  14.                 arr(j, L) = ""
  15.             Next
  16.             K = K - 1
  17.         ElseIf arr(i, 11) = arr(j, 11) And arr(i, 13) <> arr(j, 13) Then
  18.             If arr(i, 13) = "" Then
  19.             arr(i, 11) = ""
  20.             Else
  21.             arr(j, 11) = ""
  22.             End If

  24.         ElseIf arr(i, 11) <> arr(j, 11) And arr(i, 13) = arr(j, 13) Then
  25.             If arr(i, 11) = "" Then
  26.             arr(i, 13) = ""
  27.             Else
  28.             arr(j, 13) = ""
  29.             End If

  31.         ElseIf arr(i, 11) = "" And arr(i, 13) = "" Then
  32.         arr(i, 1) = ""

  34.         ElseIf arr(j, 11) = "" And arr(j, 13) = "" Then
  35.         arr(j, 1) = ""
  36. '
  37.         End If
  38.         
  39. 10:
  40.     Next
  41. Next

  43. ReDim ar(1 To K, 1 To UBound(arr, 2))
  44. K = 1
  45. For i = 1 To UBound(arr)
  46.     If arr(i, 1) <> "" Then
  47.         For L = 1 To UBound(arr, 2)
  48.             ar(K, L) = arr(i, L)
  49.         Next
  50.         K = K + 1
  51.     End If
  52. Next
  53. Range("a2:AD" & Cells(Rows.Count, 1).End(xlUp).Row).Clear
  54. [a2].Resize(UBound(ar), UBound(arr, 2)) = ar

  56. Columns(1).ClearContents
  57. [L2].Select
  58. End Sub
複製代碼
目前的問題在於,

測試少量資料時(比如說10筆以內),

看似沒有問題,

但是若測試大量資料時,

用EXCEL2007的內建的格式化條件設定,

去標出重複的值時,

會發現還是有很多重複資料沒被刪除,

需再跑第二次程式碼,

才會清除,

不知問題出在哪裡,

還望前輩不吝指點,十分感謝.

TOP

        靜思自在 : 君子如水，隨方就圓，無處不自在。
12
返回列表 上一主題