[發問] 相同資料之特定欄位第二筆資料用他值取代

b9208

先進您好
資料排序後，幾個特定欄位之資料相同者，只保留固定欄位第一筆資料，第二筆以後用0值取代。
將固定欄位等於0者，整列填滿黃色。
如附檔內說明
謝謝指導

B1.rar (8.73 KB)

下載次數: 11

2013-4-14 15:24

GBKEE

回復 1# b9208
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim DataBase As Range, I As Integer, D As Object, D_Item As Variant
   
4.     Set D = CreateObject("SCRIPTING.DICTIONARY")                            '字典物件
   
5.     With Sheets("工作表1")
   
6.         Set DataBase = .Range("A5").Resize(.[B5].End(xlDown).Row - 4, 9)    '制定範圍
   
7.     End With
   
8.     With DataBase
   
9.         .Sort Key1:=.Cells(1, 2), Order1:=xlAscending, Key2:=.Cells(1, 3), Order2:=xlAscending, Key3:=.Cells(1, 4), Order3:=xlAscending, Header:=xlYes
   
10.                                                                              '排序
    
11.         For I = 1 To .Rows.Count
    
12.             If Not D.EXISTS(Application.Phonetic(.Rows(I))) Then
    
13.                 Set D(Application.Phonetic(.Rows(I))) = .Rows(I)             ''字典物件的內容: 為Range
    
14.             Else
    
15.                 Set D(Application.Phonetic(.Rows(I))) = Union(D(Application.Phonetic(.Rows(I))), .Rows(I))
    
16.                                                        'Union 方法 傳回兩個或多個範圍的合併範圍。
    
17.             End If
    
18.         Next
    
19.         For Each D_Item In D.ITEMS                     '依序傳回 字典物件的內容
    
20.             With D_Item                                '字典物件的內容: 為Range
    
21.                 If .Rows.Count > 1 Then                '
    
22.                     For I = 2 To .Rows.Count           '從第2列開始
    
23.                         .Rows(I).Interior.Color = vbYellow
    
24.                         .Rows(I).Cells(4) = 0
    
25.                         .Rows(I).Cells(4).Font.Color = vbRed
    
26.                     Next
    
27.                 End If
    
28.             End With
    
29.         Next
    
30.     End With
    
31. End Sub

複製代碼

b9208

回復 2# GBKEE
謝謝版主
執行ok
不了解Exists & Phonetic 函數，上網查也不解。
不知道下面句子含義
If Not D.EXISTS(Application.Phonetic(.Rows(I))) Then
     Set D(Application.Phonetic(.Rows(I))) = .Rows(I)
  Else
     Set D(Application.Phonetic(.Rows(I))) = Union(D(Application.Phonetic(.Rows(I))), .Rows(I))
End If
以上謝謝

b9208

回復 3# b9208
排序範圍：
左上角[A6]，右下角為不定算，依照資料而定( 可能包含空白列或欄）

GBKEE

回復 3# b9208
不明白的函數,方法,屬性,可在程式碼中用滑鼠選取後,按F1查看說明
回復 4# b9208
程式碼須修改如下

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim DataBase As Range, I As Integer, D As Object, D_Item As Variant
   
4.     Dim W As String
   
5.     Set D = CreateObject("SCRIPTING.DICTIONARY")                            '字典物件
   
6.     With Sheets("工作表1")
   
7.         Set DataBase = .Range("A5").Resize(.[B5].End(xlDown).Row - 4, 9)    '制定範圍
   
8.     End With
   
9.     With DataBase
   
10.         .Sort Key1:=.Cells(1, 2), Order1:=xlAscending, Key2:=.Cells(1, 3), Order2:=xlAscending, Key3:=.Cells(1, 4), Order3:=xlAscending, Header:=xlYes
    
11.         '2003 排序只有3個排序欄位 :星期,料號,單位
    
12.         .Sort Key1:=.Cells(1, 2), Order1:=xlAscending, Key2:=.Cells(1, 3), Order2:=xlAscending, Key3:=.Cells(1, 6), Order3:=xlAscending, Header:=xlYes
    
13.         '再次排序:星期,料號,姓名
    
14.         For I = 1 To .Rows.Count
    
15.             With .Rows(I)
    
16.                 W = .Cells(2) & .Cells(3) & .Cells(4) & .Cells(6) '「星期+料號+單位+姓名」四欄位資料
    
17.             End With
    
18.             If Not D.Exists(W) Then
    
19.                 'Exists 方法 如果在 Dictionary 物件中指定的關鍵字存在，傳回 True，若不存在，傳回 False。
    
20.                 '語法  Object.Exists (key)
    
21.                 Set D(W) = .Rows(I)                 ''字典物件的內容: 為Range
    
22.             Else
    
23.                 Set D(W) = Union(D(W), .Rows(I))    'Union 方法 傳回兩個或多個範圍的合併範圍。
    
24.             End If
    
25.         Next
    
26.         For Each D_Item In D.ITEMS                     '依序傳回 字典物件的內容
    
27.             With D_Item                                '字典物件的內容: 為Range
    
28.                 If .Rows.Count > 1 Then                '
    
29.                     For I = 2 To .Rows.Count           '從第2列開始
    
30.                         .Rows(I).Interior.Color = vbYellow
    
31.                         .Rows(I).Cells(4) = 0
    
32.                         .Rows(I).Cells(4).Font.Color = vbRed
    
33.                     Next
    
34.                 End If
    
35.             End With
    
36.         Next
    
37.     End With
    
38. End Sub

複製代碼