[發問] 比對資料複製至工作表並排序

b9208

各位前輩
1. 依照 〞單位〞工作表之D3:G3「單位編碼」名單，複製〞資料〞工作表內相同單位編碼的資料至〞單位〞工作表。
2. 再依照單位編碼、日期及姓名順序排序資料。
感謝指導

b211.rar (4.48 KB)

下載次數: 19

2013-3-7 22:15

Hsieh

回復 1# b9208

1. Sub ex()
   
2. Dim A As Range, Rng As Range
   
3. With Sheets("資料")
   
4.    For Each A In .Range(.[F6], .[F6].End(xlDown))
   
5.       If Application.CountIf(Sheets("單位").Rows(3), A) > 0 Then
   
6.          If Rng Is Nothing Then Set Rng = A Else Set Rng = Union(Rng, A)
   
7.       End If
   
8.    Next
   
9. End With
   
10. With Sheets("單位")
    
11. .[A19].CurrentRegion.Offset(1) = ""
    
12. If Not Rng Is Nothing Then Rng.EntireRow.Copy .[A20]
    
13. .[A19].CurrentRegion.Sort key1:=.[F20], key2:=.[E20], key3:=.[H20], Header:=xlYes
    
14. End With
    
15. End Sub

複製代碼

b9208

回復 2# Hsieh
感謝Hsieh版主
目前使用上ok
努力學習程式邏輯中
謝謝

GBKEE

回復 3# b9208

1. Option Explicit
   
2. Sub Ex()  'AdvancedFilter 方法 (進階篩選)
   
3.     Dim Rng  As Range, CopyTo As Range
   
4.     Set Rng = Sheets("資料").Range("a5").CurrentRegion      '進階篩選的: 資料清單範圍(資料庫)
   
5.     'CurrentRegion 屬性 傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀。
   
6.     With Sheets("單位")
   
7.         Set CopyTo = .Range(.[A19], .[A19].End(xlToRight))   '指定被複製列的目標範圍
   
8.         Rng.AdvancedFilter xlFilterCopy, .Range(.[C3], .[C3].End(xlDown)), CopyTo, True
   
9.                                         '.Range(.[C3], .[C3].End(xlDown))      '進階篩選:準則範圍
   
10.     End With
    
11.     With CopyTo.CurrentRegion
    
12.         .Sort key1:=.Cells(6), key2:=.Cells(3), key3:=.Cells(8), Header:=xlYes
    
13.     End With
    
14.         'key1:=.Cells(6) '第一個排序欄位: .Cells(6) ->單位編碼 [F19]
    
15.         'key2:=.Cells(3) '第二個排序欄位: .Cells(3) ->日期 [C19]
    
16.         'key3:=.Cells(8) '第三個排序欄位: .Cells(8) ->姓名 [H19]
    
17. End Sub

複製代碼

下載 (39.2 KB)

2013-3-8 09:18

b9208

回復 4# GBKEE
感謝GBKEE
指導篩選條件儲存格設計方式
謝謝

b9208

回復 4# GBKEE
再請教版主
排序後「單位編碼、日期及姓名」三個欄位資料相同者，
從第二筆相同資料開始，全列（A~M欄）資料儲存格填滿黃色。如下圖片。
謝謝指導

下載 (52.97 KB)

2013-3-9 08:07

GBKEE

回復 6# b9208
是這樣嗎?

1. Option Explicit
   
2. Sub Ex()  'AdvancedFilter 方法 (進階篩選)
   
3.     Dim Rng  As Range, CopyTo As Range, i As Integer
   
4.     Dim A As String, B As String
   
5.     Set Rng = Sheets("資料").Range("a5").CurrentRegion      '進階篩選的: 資料清單範圍(資料庫)
   
6.     'CurrentRegion 屬性 傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀。
   
7.     With Sheets("單位")
   
8.         Set CopyTo = .Range(.[A19], .[A19].End(xlToRight))   '指定被複製列的目標範圍
   
9.         CopyTo.CurrentRegion.Interior.ColorIndex = 0         '儲存格底色: 設為無
   
10.         Rng.AdvancedFilter xlFilterCopy, .Range(.[c3], .[c3].End(xlDown)), CopyTo, True
    
11.                                         '.Range(.[C3], .[C3].End(xlDown))      '進階篩選:準則範圍
    
12.     End With
    
13.     With CopyTo.CurrentRegion
    
14.         .Sort key1:=.Cells(6), key2:=.Cells(3), key3:=.Cells(8), Header:=xlYes
    
15.         For i = 2 To .Rows.Count - 1
    
16.             A = .Rows(i).Cells(3) & .Rows(i).Cells(6) & .Rows(i).Cells(8)
    
17.             B = .Rows(i + 1).Cells(3) & .Rows(i + 1).Cells(6) & .Rows(i + 1).Cells(8)
    
18.             If A = B Then
    
19.                 .Rows(i).Interior.Color = vbYellow             '儲存格底色: 設為黃色
    
20.                 .Rows(i + 1).Interior.Color = vbYellow
    
21.             End If
    
22.         Next
    
23.         
    
24.     End With
    
25.         'key1:=.Cells(6) '第一個排序欄位: .Cells(6) ->單位編碼 [F19]
    
26.         'key2:=.Cells(3) '第二個排序欄位: .Cells(3) ->日期 [C19]
    
27.         'key3:=.Cells(8) '第三個排序欄位: .Cells(8) ->姓名 [H19]
    
28. End Sub

複製代碼

b9208

回復 7# GBKEE
非常感謝指導
但執行後，沒有將〞資料〞工作表符合條件的資料列複製到〞單位〞工作表。
謝謝

GBKEE

回復 8# b9208
4#圖片   A3 -> 進階篩選準則欄位 單位編碼  與工作表[資料] 的單位編碼欄位名稱要一樣

b9208

回復 9# GBKEE
GBKEE版主
執行後第二筆相同資料列沒有複製到〞單位〞工作表。如附件

b3.rar (10.63 KB)

下載次數: 9

2013-3-9 19:09