《發問》vba-名單比對相符合回寫資料

eric093

請教各位高手，關於比對名單的vba寫法，只要符合《資料來源》的A欄位符合《名單》摺頁的人名，即將特定的欄位回寫在另一個工作頁（比對後資料），
由於資料來源每日會有數千筆，所以，我寫了簡單的程式碼後，通常都要RUN很久~不知道有什麼方法可以再快些！

Sub 比對名單()

Sheets("比對後資料").Select
Cells.Clear


Sheets("資料來源").Select
k = Sheets("資料來源").Range("a65536").End(xlUp).Row
p = Sheets("名單").Range("a65536").End(xlUp).Row

Sheets("比對後資料").Cells(1, 1).Value = Sheets("資料來源").Cells(1, 1)
Sheets("比對後資料").Cells(1, 4).Value = Sheets("資料來源").Cells(1, 3)
Sheets("比對後資料").Cells(1, 5).Value = Sheets("資料來源").Cells(1, 4)
  c = 2
For n = 2 To k
       For m = 1 To p

  If Sheets("資料來源").Cells(n, 1) = Sheets("名單").Cells(m, 1) Then                     
        Sheets("比對後資料").Cells(c, 1).Value = Sheets("資料來源").Cells(n, 1)
         Sheets("比對後資料").Cells(c, 3).Value = Sheets("資料來源").Cells(n, 3)
        Sheets("比對後資料").Cells(c, 4).Value = Sheets("資料來源").Cells(n, 4)
         
               c = c + 1
              
               
   
   End If
    Next
  Next
  
  

End Sub

Hsieh

回復 1# eric093

1. Sub ex()
   
2. Dim A As Range, Rng As Range, Ar(), s&
   
3. With Sheets("名單")
   
4.    For Each A In .Range(.[A2], .[A2].End(xlDown))
   
5.    With Sheets("資料來源")
   
6.    Set Rng = .[A:A].Find(A, lookat:=xlWhole)
   
7.    If Not Rng Is Nothing Then
   
8.    ReDim Preserve Ar(s)
   
9.    Ar(s) = Application.Transpose(Application.Transpose(Rng.Resize(, 4).Value))
   
10.    s = s + 1
    
11.    End If
    
12.    End With
    
13.    Next
    
14. End With
    
15. With Sheets("比對後資料")
    
16. .[A1].CurrentRegion.Offset(1) = ""
    
17. .[A2].Resize(s, 4) = Application.Transpose(Application.Transpose(Ar))
    
18. End With
    
19. End Sub

複製代碼

eric093

回復 2# Hsieh


    感謝！我套入後，資料來源符合名單的只會出現一次，如果，資料來源中，人名出現多次也會同樣會帶入比對資料的摺頁，要怎麼做？
    不好意思，我剛剛沒有表達清楚！

Hsieh

回復 3# eric093

1. Sub ex()
   
2. Dim A As Range, Rng As Range, Ar(), s&
   
3. With Sheets("名單")
   
4.    For Each A In .Range(.[A2], .[A2].End(xlDown))
   
5.    With Sheets("資料來源")
   
6.    Set Rng = .[A:A].Find(A, lookat:=xlWhole)
   
7.    If Not Rng Is Nothing Then
   
8.    For Each c In .Range(Rng, Rng.End(xlDown))
   
9.    If c = A Then
   
10.       ReDim Preserve Ar(s)
    
11.       Ar(s) = Application.Transpose(Application.Transpose(c.Resize(, 4).Value))
    
12.       s = s + 1
    
13.    End If
    
14.    Next
    
15.    End If
    
16.    End With
    
17.    Next
    
18. End With
    
19. With Sheets("比對後資料")
    
20. .[A1].CurrentRegion.Offset(1) = ""
    
21. .[A2].Resize(s, 4) = Application.Transpose(Application.Transpose(Ar))
    
22. End With
    
23. End Sub

複製代碼

eric093

謝謝！可以套入了！但是
可請教幾個問題嗎？（我初入門不太了解，所以問了笨問題）

For Each A In .Range(.[A2], .[A2].End(xlDown))
為什麼  .Range前面會有個點，而(.[A2], .[A2].也都會有個點


If Not Rng Is Nothing Then  這句程序碼的意思？

s&  這是定義什麼？

如果，我想取的資料來源若不是連續欄位？（可能是A、B、C、G、I欄）是不是就不可以用
Ar(s) = Application.Transpose(Application.Transpose(c.Resize(, 4).Value))

GBKEE

回復 5# eric093
有不解之處 論壇中搜尋關鍵字,多看看會進步的.
另一寫法供參考

1. Option Explicit
   
2. Sub 比對名單()
   
3.     Dim Rng(1 To 3) As Range, E As Range
   
4.     Sheets("比對後資料").UsedRange.Offset(1).Clear ''第一列的 姓名,居住地,性別,年齡,不清除
   
5.     Set Rng(1) = Sheets("資料來源").Range("A:A")                    '資料來源名單
   
6.     Set Rng(2) = Sheets("名單").Range("A2")                         '第一個人名
   
7.     Do While Rng(2) <> ""
   
8.         Set Rng(3) = Rng(1).Find(Rng(2), lookat:=xlWhole)           '資料來源名單中搜尋人名
   
9.         If Not Rng(3) Is Nothing Then                               'Not Rng Is Nothing :有找到人名
   
10.             Rng(1).Replace Rng(2), "=gbkee", xlWhole                '將相同的人名替換為錯誤值
    
11.             With Rng(1).SpecialCells(xlCellTypeFormulas, xlErrors)  '特殊的範圍(公式,錯誤值)
    
12.                 .Value = Rng(2)                                     '錯誤值改回人名
    
13.                 For Each E In .Cells                                'Each E : 一個陣列或集合中的每一元素或成員
    
14.                     With Sheets("比對後資料")
    
15.                         'E.Resize(, 4).Copy .Cells(.UsedRange.Rows.Count + 1, "A")  '連續的4欄
    
16.                         '可能是A、B、C、G、I欄 (不連續5欄)
    
17.                         .Cells(.UsedRange.Rows.Count + 1, "A").Resize(, 5) = Array(E, E.Range("B1"), E.Range("C1"), E.Range("G1"), E.Range("I1"))
    
18.                     End With
    
19.                 Next
    
20.             End With
    
21.         End If
    
22.         Set Rng(2) = Rng(2).Offset(1)                               '下一個人名
    
23.     Loop
    
24. End Sub

複製代碼

b9208

回復 6# GBKEE
Dear GBKEE
如果〞資料來源〞A欄為 12碼編號（如：1001QWER7895）
〞名單〞符合其中三碼（如：QWE），編號第5~7三碼或任何位置三碼。
程式碼如何修訂
感謝指導

GBKEE

回復 7# b9208

1. Option Explicit
   
2. Option Base 1
   
3. Sub 比對名單()
   
4.     Dim Ar(1 To 2), Ax(), E As Variant, i As Integer, S As Integer
   
5.     Ar(1) = Application.Transpose(Sheets("名單").UsedRange.Columns(1))  '名單的資料轉入陣列
   
6.     Ar(2) = Sheets("資料來源").UsedRange                                '資料來源的資料轉入陣列
   
7.     S = 1
   
8.     For Each E In Ar(1)       '*** 請修正 名單的標頭= 資料來源:名單的標頭
   
9.         For i = 1 To UBound(Ar(2))
   
10.             If InStr(Ar(2)(i, 1), E) Then    '有比對到>0 條件成立
    
11.             'InStr 函數 傳回在某字串中一字串的最先出現位置，此位置為 Variant (Long)。
    
12.             ReDim Preserve Ax(S)
    
13.             Ax(S) = Application.Index(Ar(2), i)  '取連續欄位
    
14.             '******* 取不連續的欄位 'A.B.C.E.G,H->1,2,3,5,7,8
    
15.             'Ax(S) = Array(Ax(S)(1), Ax(S)(2), Ax(S)(3), Ax(S)(5), Ax(S)(7), Ax(S)(8))
    
16.             S = S + 1
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     Sheets("比對後資料").UsedRange.Clear    '全部清除
    
21.     Sheets("比對後資料").[a1].Resize(UBound(Ax, 1), UBound(Ax(1))) = Application.Transpose(Application.Transpose(Ax))
    
22. End Sub

複製代碼

b9208

回復 8# GBKEE
非常感謝版大
程式碼可以運用執行

eric093

謝謝版主提醒及指導，也謝謝 GBKEE！我會再加油的，每天認真爬文的！
真的很感謝！