返回列表 上一主題 發帖

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2014-1-18 21:04 | 顯示全部帖子
回復 13# eric093
試試看
  1. Option Explicit
  2. Sub tt()
  3.     Dim Rng(1 To 3) As Range, E As Range
  4.     Set Rng(1) = Sheets("名單").Range("a2")
  5.     Set Rng(2) = Sheets("資料來源").Range("a:a")
  6.     Sheets("比對後資料").UsedRange.Offset(1).Clear ''清除舊有資料
  7.     Do While Rng(1) <> ""
  8.         Set Rng(3) = Rng(2).Find(Rng(1), lookat:=xlWhole)
  9.         If Not Rng(3) Is Nothing Then
  10.             Rng(2).Replace Rng(1), "=book", xlWhole
  11.             With Rng(2).SpecialCells(xlCellTypeFormulas, xlErrors)
  12.                 .Value = Rng(1)
  13.                 For Each E In .Cells
  14.                     With Sheets("比對後資料")
  15.                         With .Cells(.UsedRange.Rows.Count + 1, "A")
  16.                             .Range("A1") = E
  17.                             .Range("B1") = E.Range("B1")
  18.                             .Range("C1") = Rng(1).Range("B1")
  19.                         End With
  20.                    End With
  21.                 Next
  22.             End With
  23.         End If
  24.         Set Rng(1) = Rng(1).Offset(1)
  25.     Loop
  26. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2014-2-10 12:56 | 顯示全部帖子
回復 16# handsometrowa
  1. Option Explicit
  2. Sub tt()
  3.     Dim Rng(1 To 3) As Range, E As Range
  4.     Set Rng(1) = Sheets("名單").Range("a2")
  5.     Set Rng(2) = Sheets("資料來源").Range("a:a")
  6.     Sheets("比對後資料").UsedRange.Offset(1).Clear ''清除舊有資料
  7.     Do While Rng(1) <> ""
  8.         Set Rng(3) = Rng(2).Find(Rng(1), lookat:=xlWhole)
  9.         If Not Rng(3) Is Nothing Then    '確定範圍有Rng(1)的字串
  10.             '通常要搜尋特定的資料資串會用FIND 一一的搜尋
  11.             '這裡用Replace 方法 一次將搜尋特定的資料資串,改為錯誤值
  12.             '也是一中搜尋特定的資料資串的方法
  13.             Rng(2).Replace Rng(1), "=book", xlWhole
  14.             With Rng(2).SpecialCells(xlCellTypeFormulas, xlErrors) '特殊的範圍(公式,錯誤值)
  15.                                                                    'Rng(2)範圍有"錯誤值"的儲存格
  16.                 .Value = Rng(1)  '更正回原有的資料
  17.                 For Each E In .Cells
  18.                     With Sheets("比對後資料")
  19.                         With .Cells(.UsedRange.Rows.Count + 1, "A")
  20.                             .Range("A1") = E
  21.                             .Range("B1") = E.Range("B1")
  22.                             .Range("C1") = Rng(1).Range("B1")
  23.                         End With
  24.                    End With
  25.                 Next
  26.             End With
  27.         End If
  28.         Set Rng(1) = Rng(1).Offset(1)
  29.     Loop
  30. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

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-2-12 10:34 | 顯示全部帖子
回復 18# yen956

Dim A As Long

   
VBA 的說明

Long 資料型態 Long (長整數)變數係以範圍從 -2,147,483,648 到 2,147,483,647 之 32 位元 (4 個位元組) 有號數字形式儲存。Long 的型態宣告字元為 &。
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2014-2-12 17:09 | 顯示全部帖子
回復 20# yen956
   
一向很少用Option Explicit,

如程式龐大些,這習慣不好.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 能幹不幹，不如苦幹實幹。
返回列表 上一主題