123
返回列表 上一主題 發帖

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

eric093

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


    先謝謝版主看到我的求救！
我說明一下~
原程式內容已可以回寫資料來源（我也弄懂了），但我嘗試要將名單摺頁的B欄（性別）也一併帶入比對後資料！
我試了好久，也上網查了好久，我實在能力不足，無法參透如何改！

名單比對練習.rar (8.39 KB)

新人一枚

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
12#
發表於 2014-1-18 20:25 | 只看該作者
回復 11# eric093
  1. '沒看到檔案不解為何要
  2. For Each E In .Cells      
  3.                 For Each K In .Cells
  4. '有兩個  For Each  , 一個  For Each 不行嗎?
  5.                    With Sheets("比對後資料")
  6.                     前面要      .Cells(.UsedRange.Rows.Count + 1, "C").Value = K.Offset(, 1)
  7.                     前面要     .Cells(.UsedRange.Rows.Count, "A").Value = E
  8.                     前面要     .Cells(.UsedRange.Rows.Count, "B").Value = E.Range("B1")                     
  9.                
  10.                    End With
  11.                 Next
  12.              Next
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

eric093

帖子
77 
主題
30 
精華
0 
積分
110 
點名
0  
作業系統
win7 
軟體版本
office2003 
閱讀權限
20 
性別
男 
來自
台北 
註冊時間
2013-7-14 
最後登錄
2018-10-3 
11#
發表於 2014-1-18 19:34 | 只看該作者
我以GBKEE版主提供的進行了解後，要再調整將SHEETS("名單")的B欄位也同時回寫在SHEETS("比對後資料")，經改了一下後，結果帶出的資料不正確，請大家指導我！


Sub tt()
Dim rng(1 To 5) As Range, E, K As Range

Set rng(1) = Sheets("名單").Range("a2")

Set rng(3) = Sheets("資料來源").Range("a:a")

Do While rng(1) <> ""
Set rng(4) = rng(3).Find(rng(1), lookat:=xlWhole)

If Not rng(4) Is Nothing Then
       rng(3).Replace rng(1), "=book", xlWhole
       With rng(3).SpecialCells(xlCellTypeFormulas, xlErrors)
            .Value = rng(1)
            With rng(1)
             For Each E In .Cells
                For Each K In .Cells
               
                   With Sheets("比對後資料")
                         Cells(.UsedRange.Rows.Count + 1, "C").Value = K.Offset(, 1)
                        Cells(.UsedRange.Rows.Count, "A").Value = E
                        Cells(.UsedRange.Rows.Count, "B").Value = E.Range("B1")
                     
               
                   End With
                Next
             Next
             End With
       End With
      
      
End If
Set rng(1) = rng(1).Offset(1)


Loop




End Sub
新人一枚

TOP

eric093

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

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

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 
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兔年全勤獎章
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

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

Hsieh

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

2025年全勤獎章2024年全勤獎章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

        靜思自在 : 人要知福、惜福、再造福。
123
返回列表 上一主題