[發問] 如何對特定欄進行篩選和替代資料

luke

各位先進

1. sheet1表的A:C欄為資料區, 約有500列(含空白列), 其中B欄資料(含有黃底色的儲存格), 當按下『篩選』
    按鍵就會抓取B欄有黃底的儲存格至L:N欄(PS: L欄=N欄, M欄取C欄)

2.完成篩選後, B欄有黃底的儲存格想要利用L欄與N欄[N欄是由人工輸入資料,視情況會做修改]相對應關係,
   當按下『替代』按鍵, 只需對B欄進行字母的替代(其他欄位不需做替代),
   即取N欄相對應至L欄的儲存格資料, 去對B欄所有黃底的儲存格做文字替代.

3.若N欄資料中, 有與B欄非黃底儲存格的資料相同時就停止執行VBA動作並顯示該重複值.

煩請先進 大大指導

TEST28.rar (29.58 KB)

下載次數: 8

2013-5-25 22:27

GBKEE

回復 1# luke

1. Option Explicit
   
2. Dim D As Object, DRng As Range
   
3. Sub 篩選()
   
4.     資料篩選
   
5.     With Sheet1.Range("L1")
   
6.         .CurrentRegion = ""
   
7.         If D.Count = 0 Then Exit Sub
   
8.         .Resize(D.Count, 3) = Application.Transpose(Application.Transpose(D.ITEMS))
   
9.         .CurrentRegion.Sort .Cells(1)
   
10.     End With
    
11. End Sub
    
12. Sub 替代()
    
13.     Dim Rng As Range, R As Range, E As Range, C As Range
    
14.     資料篩選
    
15.     Application.ScreenUpdating = False
    
16.     With Sheet1
    
17.         .Range("C:C").Value = .Range("C:C").Value  '去除"'"字串'L1 多一個
    
18.         Set Rng = .Range("L1").CurrentRegion
    
19.         For Each R In Rng.Columns(2).Cells   'M欄的儲存格
    
20.             If DRng.Find(R.Offset(, 1), lookat:=xlWhole) Is Nothing And Application.CountIf(.[B:B], R.Offset(, 1)) > 0 Then
    
21.                 'N欄資料中, 有與B欄非黃底儲存格的資料相同時就停止執行VBA->    'N欄的字串在[篩選資料的儲存格]中比對不到, 且[B:B]中有此字串
    
22.                 With .Range("B:B")
    
23.                     .Replace R.Offset(, 1), "=XXX", xlWhole
    
24.                     With .SpecialCells(xlCellTypeFormulas, xlErrors)
    
25.                          .Value = R.Offset(, 1)
    
26.                          .Select
    
27.                     End With
    
28.                 End With
    
29.                 MsgBox R.Offset(, 1) & " 有重複值."
    
30.                 End
    
31.             End If
    
32.             With .Range("C:C")
    
33.                 .Replace R.Value, "=XXX", xlWhole
    
34.                 With .SpecialCells(xlCellTypeFormulas, xlErrors)
    
35.                     .Value = R
    
36.                     For Each E In .Areas
    
37.                         For Each C In E.Cells
    
38.                             If C.Offset(, -1) = R.Offset(, -1) Then C.Offset(, -1) = R.Offset(, 1)
    
39.                         Next
    
40.                     Next
    
41.                 End With
    
42.             End With
    
43.         Next
    
44.     End With
    
45.     Application.ScreenUpdating = True
    
46. End Sub
    
47. Private Sub 資料篩選()
    
48.     Dim R As Range
    
49.     Set D = CreateObject("SCRIPTING.DICTIONARY")
    
50.     With Sheet1
    
51.         For Each R In .Range("B1", .Cells(.Rows.Count, "B").End(xlUp))
    
52.             If R <> "" And R.Cells(1, 2) <> "" Then
    
53.                 D(R & R.Cells(1, 2)) = Array(R, R.Cells(1, 2), R)    '存入字典物件: 篩選的資料
    
54.                 If DRng Is Nothing Then                              '篩選資料的儲存格
    
55.                     Set DRng = R
    
56.                 Else
    
57.                     Set DRng = Union(R, DRng)
    
58.                 End If
    
59.             End If
    
60.         Next
    
61.    End With
    
62. End Sub

複製代碼

luke

回復 2# GBKEE


謝謝超版回覆

1.當按下『替代』按鍵去對B欄進行字母的替代時會出現1004錯誤, 是否因執行子VBA即  "資料篩選" 所造成?

下載 (12.84 KB)

2013-5-26 20:46

2.如果直接改用下列"替代"語法也許較容易, 但要如何兼顧[N欄資料中與B欄非黃底儲存格的資料相同時就停止執行VBA], 應如何修改VBA?

Columns("B:B").Select
Selection.Replace What:=a, Replacement:=a.Offset(, 2), lookat:=xlPart, ReplaceFormat:=False
(a=L欄)

以上

煩請指導.
TEST28A.rar (26.52 KB)

下載次數: 7

2013-5-26 20:46

GBKEE

回復 3# luke
在附檔上的字串 L1 實際上是 'L1  ->文字格式   
用這行除去 '  在2003版本可除去,但2007版本為何無法除去尚請有2007試試看

1. .Range("C:C").Value = .Range("C:C").Value  '去除"'"字串'L1 多一個

複製代碼

下載 (15.07 KB)

2013-5-26 21:40

Hsieh

回復 1# luke

1. Sub 篩選()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. With sheet1
   
4.    For Each a In .Range(.[B1], .Cells(.Rows.Count, 2).End(xlUp))
   
5.       If a.Interior.ColorIndex = 6 Then d(a.Value) = Array(a, a.Offset(, 1), a)
   
6.    Next
   
7.    With .Range("L1")
   
8.       .CurrentRegion = ""
   
9.       .Resize(d.Count, 3) = Application.Transpose(Application.Transpose(d.items))
   
10.       .Resize(d.Count, 3).Sort .Cells(1, 1), xlAscending, Header:=xlNo
    
11.    End With
    
12. End With
    
13. End Sub
    
14. Sub 取代()
    
15. Set d = CreateObject("Scripting.Dictionary")
    
16. Set d1 = CreateObject("Scripting.Dictionary")
    
17. With sheet1
    
18.    With .Range("L1").CurrentRegion
    
19.    For Each a In .Columns(1).Cells
    
20.       d(a.Value) = a.Offset(, 2)
    
21.       d1(a.Offset(, 2).Value) = a.Value
    
22.    Next
    
23.    End With
    
24.    For Each a In .Range(.[B1], .Cells(.Rows.Count, 2).End(xlUp))
    
25.      If d1.exists(a.Value) And a.Interior.ColorIndex <> 6 Then MsgBox "資料重複": Exit Sub
    
26.    Next
    
27.    For Each a In .Range(.[B1], .Cells(.Rows.Count, 2).End(xlUp))
    
28.      If d.exists(a.Value) And a.Interior.ColorIndex = 6 Then a.Value = d(a.Value)
    
29.    Next
    
30.    MsgBox "取代完成"
    
31. End With
    
32. End Sub

複製代碼

luke

回復 5# Hsieh


回覆H超版

謝謝協助賀幫忙修改
再次感謝


以上