123
返回列表 上一主題 發帖

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

eric093

帖子
77 
主題
30 
精華
0 
積分
110 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台北 
註冊時間
2013-7-14 
最後登錄
2018-10-3 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-1-16 22:12 | 只看該作者

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

請教各位高手，關於比對名單的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

Book1.rar (1.65 KB)

Book1.rar (1.65 KB)

收藏 分享
新人一枚

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
98  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-4-27 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2014-1-16 22:50 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

eric093

帖子
77 
主題
30 
精華
0 
積分
110 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台北 
註冊時間
2013-7-14 
最後登錄
2018-10-3 
3#
發表於 2014-1-16 23:10 | 只看該作者
回復 2# Hsieh


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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
98  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-4-27 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 2014-1-16 23:24 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

eric093

帖子
77 
主題
30 
精華
0 
積分
110 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台北 
註冊時間
2013-7-14 
最後登錄
2018-10-3 
5#
發表於 2014-1-16 23:44 | 只看該作者
[版主管理留言]
  • Hsieh(2014-1-16 23:53): 這些都是基本問題，論壇中都討論過，新手就請多爬文

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

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))
新人一枚

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2014-1-17 09:29 | 只看該作者
本帖最後由 GBKEE 於 2014-1-17 10:11 編輯

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
7#
發表於 2014-1-17 10:51 | 只看該作者
回復 6# GBKEE
Dear GBKEE
如果〞資料來源〞A欄為 12碼編號（如：1001QWER7895）
〞名單〞符合其中三碼（如：QWE），編號第5~7三碼或任何位置三碼。
程式碼如何修訂
感謝指導
100 字節以內
不支持自定義 Discuz! 代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
8#
發表於 2014-1-17 12:32 | 只看該作者
回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
9#
發表於 2014-1-17 15:34 | 只看該作者
回復 8# GBKEE
非常感謝版大
程式碼可以運用執行
100 字節以內
不支持自定義 Discuz! 代碼

TOP

eric093

帖子
77 
主題
30 
精華
0 
積分
110 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台北 
註冊時間
2013-7-14 
最後登錄
2018-10-3 
10#
發表於 2014-1-17 17:57 | 只看該作者
謝謝版主提醒及指導，也謝謝 GBKEE！我會再加油的，每天認真爬文的！
真的很感謝！
新人一枚

TOP

        靜思自在 : 有智慧才能分辨善惡邪正；有謙虛才能建立美滿人生。
123
返回列表 上一主題