麻辣家族討論版版 - Powered by Discuz! Board

標題: 《發問》vba-名單比對相符合回寫資料 [打印本頁]

作者: eric093 時間: 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

作者: Hsieh 時間: 2014-1-16 22:50

回復 1# eric093

Sub ex()
Dim A As Range, Rng As Range, Ar(), s&
With Sheets("名單")
For Each A In .Range(.[A2], .[A2].End(xlDown))
With Sheets("資料來源")
Set Rng = .[A:A].Find(A, lookat:=xlWhole)
If Not Rng Is Nothing Then
ReDim Preserve Ar(s)
Ar(s) = Application.Transpose(Application.Transpose(Rng.Resize(, 4).Value))
s = s + 1
End If
End With
Next
End With
With Sheets("比對後資料")
.[A1].CurrentRegion.Offset(1) = ""
.[A2].Resize(s, 4) = Application.Transpose(Application.Transpose(Ar))
End With
End Sub

複製代碼

作者: eric093 時間: 2014-1-16 23:10

回復 2# Hsieh

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

作者: Hsieh 時間: 2014-1-16 23:24

回復 3# eric093

Sub ex()
Dim A As Range, Rng As Range, Ar(), s&
With Sheets("名單")
For Each A In .Range(.[A2], .[A2].End(xlDown))
With Sheets("資料來源")
Set Rng = .[A:A].Find(A, lookat:=xlWhole)
If Not Rng Is Nothing Then
For Each c In .Range(Rng, Rng.End(xlDown))
If c = A Then
ReDim Preserve Ar(s)
Ar(s) = Application.Transpose(Application.Transpose(c.Resize(, 4).Value))
s = s + 1
End If
Next
End If
End With
Next
End With
With Sheets("比對後資料")
.[A1].CurrentRegion.Offset(1) = ""
.[A2].Resize(s, 4) = Application.Transpose(Application.Transpose(Ar))
End With
End Sub

複製代碼

作者: eric093 時間: 2014-1-16 23:44

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

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 時間: 2014-1-17 09:29

本帖最後由 GBKEE 於 2014-1-17 10:11 編輯

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

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

複製代碼

作者: b9208 時間: 2014-1-17 10:51

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

作者: GBKEE 時間: 2014-1-17 12:32

回復 7# b9208

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

複製代碼

作者: b9208 時間: 2014-1-17 15:34

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

作者: eric093 時間: 2014-1-17 17:57

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

作者: eric093 時間: 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

作者: GBKEE 時間: 2014-1-18 20:25

回復 11# eric093

'沒看到檔案不解為何要
For Each E In .Cells
For Each K In .Cells
'有兩個 For Each , 一個 For Each 不行嗎?
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

複製代碼

作者: eric093 時間: 2014-1-18 20:45

回復 12# GBKEE

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

作者: GBKEE 時間: 2014-1-18 21:04

回復 13# eric093
試試看

Option Explicit
Sub tt()
Dim Rng(1 To 3) As Range, E As Range
Set Rng(1) = Sheets("名單").Range("a2")
Set Rng(2) = Sheets("資料來源").Range("a:a")
Sheets("比對後資料").UsedRange.Offset(1).Clear ''清除舊有資料
Do While Rng(1) <> ""
Set Rng(3) = Rng(2).Find(Rng(1), lookat:=xlWhole)
If Not Rng(3) Is Nothing Then
Rng(2).Replace Rng(1), "=book", xlWhole
With Rng(2).SpecialCells(xlCellTypeFormulas, xlErrors)
.Value = Rng(1)
For Each E In .Cells
With Sheets("比對後資料")
With .Cells(.UsedRange.Rows.Count + 1, "A")
.Range("A1") = E
.Range("B1") = E.Range("B1")
.Range("C1") = Rng(1).Range("B1")
End With
End With
Next
End With
End If
Set Rng(1) = Rng(1).Offset(1)
Loop
End Sub

複製代碼

作者: eric093 時間: 2014-1-18 21:11

謝謝版大
我懂我卡在哪了！

作者: handsometrowa 時間: 2014-2-10 12:00

回復 6# GBKEE

請問G大
關於下面三句，我有點不解，為什麼找出相同人名之後，需要將範圍變成錯誤  ，卻又要在後面把人名又改正確呢....@@?

Rng(1).Replace Rng(2), "=gbkee", xlWhole             '將相同的人名替換為錯誤值
         With Rng(1).SpecialCells(xlCellTypeFormulas, xlErrors)  '特殊的範圍(公式,錯誤值)
            .Value = Rng(2)

作者: GBKEE 時間: 2014-2-10 12:56

回復 16# handsometrowa

Option Explicit
Sub tt()
Dim Rng(1 To 3) As Range, E As Range
Set Rng(1) = Sheets("名單").Range("a2")
Set Rng(2) = Sheets("資料來源").Range("a:a")
Sheets("比對後資料").UsedRange.Offset(1).Clear ''清除舊有資料
Do While Rng(1) <> ""
Set Rng(3) = Rng(2).Find(Rng(1), lookat:=xlWhole)
If Not Rng(3) Is Nothing Then '確定範圍有Rng(1)的字串
'通常要搜尋特定的資料資串會用FIND 一一的搜尋
'這裡用Replace 方法一次將搜尋特定的資料資串,改為錯誤值
'也是一中搜尋特定的資料資串的方法
Rng(2).Replace Rng(1), "=book", xlWhole
With Rng(2).SpecialCells(xlCellTypeFormulas, xlErrors) '特殊的範圍(公式,錯誤值)
'Rng(2)範圍有"錯誤值"的儲存格
.Value = Rng(1) '更正回原有的資料
For Each E In .Cells
With Sheets("比對後資料")
With .Cells(.UsedRange.Rows.Count + 1, "A")
.Range("A1") = E
.Range("B1") = E.Range("B1")
.Range("C1") = Rng(1).Range("B1")
End With
End With
Next
End With
End If
Set Rng(1) = Rng(1).Offset(1)
Loop
End Sub

複製代碼

作者: yen956 時間: 2014-2-12 09:41

回復 4# Hsieh
請問大大：
Dim A As Range, Rng As Range, Ar(), s&
中的 s& 作用是什麼?
(我用 "Dim s&" 站內搜尋過了, 搜不到)

作者: GBKEE 時間: 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 的型態宣告字元為 &。

作者: yen956 時間: 2014-2-12 12:27

謝謝GBKEE大, 詳細的解說,
一向很少用Option Explicit,
竟然連最基本的資料型態都忘了,
要好好爬文了, 謝謝.

作者: GBKEE 時間: 2014-2-12 17:09

回復 20# yen956

一向很少用Option Explicit,

如程式龐大些,這習慣不好.

作者: yen956 時間: 2014-2-12 18:35

回復 21# GBKEE
沒錯, 改進中.
謝謝G大再三指導, 謝謝!!

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