Board logo

標題: [發問] 比對資料複製至工作表並排序 [打印本頁]
作者: b9208    時間: 2013-3-7 22:15     標題: 比對資料複製至工作表並排序

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

[attach]14305[/attach]
作者: Hsieh    時間: 2013-3-7 22:44

回復 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    時間: 2013-3-7 23:09

回復 2# Hsieh
感謝Hsieh版主
目前使用上ok
努力學習程式邏輯中
謝謝
作者: GBKEE    時間: 2013-3-8 09:18

回復 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
複製代碼
[attach]14307[/attach]
作者: b9208    時間: 2013-3-8 09:58

回復 4# GBKEE
感謝GBKEE
指導篩選條件儲存格設計方式
謝謝
作者: b9208    時間: 2013-3-9 08:13

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

回復 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    時間: 2013-3-9 12:14

回復 7# GBKEE
非常感謝指導
但執行後，沒有將〞資料〞工作表符合條件的資料列複製到〞單位〞工作表。
謝謝
作者: GBKEE    時間: 2013-3-9 12:32

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

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

[attach]14319[/attach]
作者: Hsieh    時間: 2013-3-10 09:51

回復 10# b9208

Rng.AdvancedFilter xlFilterCopy, .Range(.[c3], .[c3].End(xlDown)), CopyTo, False
作者: b9208    時間: 2013-3-10 10:45

回復 11# Hsieh
謝謝Hsieh版主指導
前Hsieh版主協助程式碼採無標題列排序，符合需求，因實際運用標題列是有三列合併的（如下圖）。
今想增加相同資料列，從其第二筆資料開始填滿黃色標示。
[attach]14324[/attach]
作者: b9208    時間: 2013-3-10 10:48

回復 9# GBKEE
GBKEE版主您好
依照例子執行OK
但實際運用標題列是有三列合併格的設計（如圖）
非常抱歉沒有說明清楚
[attach]14325[/attach]
作者: Hsieh    時間: 2013-3-10 10:48

回復 12# b9208
標題列禁用合併儲存格，這是資料庫使用必須遵守的原則
你這樣會造成無法使用進階篩選
作者: b9208    時間: 2013-3-10 11:11

回復 14# Hsieh
謝謝HSIEH版主指導
修改報表標題設計格式，符合沒有合併格的格式。
感謝版主受益良多
作者: b9208    時間: 2013-3-11 21:52

回復 14# Hsieh
Dear Hsieh
小弟完成程式如附件
今再請教：
一、如何修正只有資料範圍填滿黃色。
二、相同資料列再比較k欄數量，保留一個最大值，其他數值改為0，格式為粗体紅字。
感謝指導

[attach]14334[/attach]
作者: Hsieh    時間: 2013-3-11 22:41

回復 16# b9208
  1. Sub ex()
  2. Dim A As Range, C As Range, Rng As Range, MyRng As Range, m$
  3. Set d = CreateObject("Scripting.Dictionary")
  4. Set d1 = CreateObject("Scripting.Dictionary")
  5. With Sheets("單位")
  6. Set Rng = .[D3:G3]
  7.    With Sheets("資料")
  8.       For Each A In .Range(.[F6], .[F6].End(xlDown))
  9.       m = A.Offset(, -3) & A & A.Offset(, 2)
  10.       If d(m) <= A.Offset(, 5).Value Then d(m) = A.Offset(, 5).Value '記住最大值
  11.       d1(m) = d1(m) + 1 '計算個數
  12.          Set C = Rng.Find(A, lookat:=xlWhole)
  13.          If Not C Is Nothing Then
  14.            If MyRng Is Nothing Then Set MyRng = A.Offset(, -5).Resize(, 13) Else Set MyRng = Union(MyRng, A.Offset(, -5).Resize(, 13))
  15.          End If
  16.       Next
  17.     End With
  18.     .Range("A19").CurrentRegion.Interior.ColorIndex = 0
  19.     If Not MyRng Is Nothing Then MyRng.Copy .[A20] Else MsgBox "無符合資料": Exit Sub
  20.     .Range("A19").CurrentRegion.Sort key1:=.[K19], Header:=xlYes
  21.     .Range("A19").CurrentRegion.Sort key1:=.[F19], key2:=.[C19], key3:=.[H19], Header:=xlYes
  22.     For Each A In .Range(.[F20], .[F20].End(xlDown))
  23.     m = A.Offset(, -3) & A & A.Offset(, 2)
  24.        If d1(m) > 1 Then A.Offset(, -5).Resize(, 13).Interior.ColorIndex = 6 '有重複
  25.        If A.Offset(, 5) <> d(m) Then A.Offset(, 5) = 0 '不等於最大值就歸零
  26.     Next
  27. End With
  28. End Sub
複製代碼
作者: b9208    時間: 2013-3-12 06:38

回復 17# Hsieh
謝謝Hsieh版本
執行ok
請教k欄最大值有二筆以上相同，可以保留第一筆數值，第二筆以後都為0。
目前執行後有相同最大值都保留。
謝謝指導
作者: Hsieh    時間: 2013-3-12 10:07

回復 18# b9208

最後一句
       If A.Offset(, 5) <> d(m) Then A.Offset(, 5) = 0 Else d(m) = 0 '不等於最大值就歸零
作者: b9208    時間: 2013-3-12 23:08

回復 19# Hsieh
Dear Hsieh
非常感謝您
執行後符合需要
多謝



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)