excel vba 查找

markbaseball

(工作表1)                                                                     (工作表2)                           
          2001 2002 2003 2004 2005                                             
A           2      4        1        0       12                                     D  2002      8
B           3       5       0        0         7                                      F  2003      9
C           7      0       4        2          5                                     G  2001
D           0      8      9         7         2
E           7     10     11      5         8
F          6       8        9      10       0
請問我從工作表1的總檔中，查找工作表2的代號及相同年分，如果都符合的話，則把工作表1中符合的值，貼到工作表2中相對應的儲存格中
但是目前我的程式跑不動，因此希望各位高手可以幫忙看看

Sub ro()
Dim ii, kk As Integer
Dim jj As Long
Dim AA, TT As Object
  Set AA = Worksheets("工作表1")
  Set TT = .Worksheets("工作表2")
   For jj = 3 To 22355
     For ii = 2 To 1068
       For kk = 3 To 40
           Set cusip = AA.Cells(jj, 2).Find(What:=TT.Cells(ii, 6), LookIn:=xlFormulas)   '從工作表1查詢和樣本相同cusip'
           If Not cusip Is Nothing Then
                Set tdate = AA.Cells(1, kk).Find(What:=TT.Cells(ii, 2), LookIn:=xlFormulas)     '尋找相同年分'
                If Not tdate Is Nothing Then
                AA.Cells(jj, kk).Copy Destination:=TT.Cells(ii, 7)
                End If
           Else
           End If
       Next kk
     Next ii
   Next jj
End Sub

lpk187

回復 1# markbaseball
善用區域變數視窗以及F8(逐步執行)來觀看你的代碼，就容易抓到問題所在了

1. Sub ro()
   
2.     Dim ro As Integer
   
3.     Dim AA As Worksheet
   
4.     Dim rng As Range, r As Range, c As Range
   
5.     Set AA = Worksheets("工作表1")
   
6.     With Sheets("工作表2") '以工作表2做目標區域
   
7.         ro = .[A65535].End(xlUp).Row '尋找A欄的最後一格的列號
   
8.         For Each rng In .Range("a1:a" & ro) '以A1:A(ro的數值)為範圍做循環
   
9.             Set r = AA.Columns(1).Find(rng, LookIn:=xlFormulas) '在工作表1的A欄(Columns(1))，尋找代號
   
10.             Set c = AA.Rows(1).Find(rng.Offset(, 1), LookIn:=xlFormulas) '在工作表1的第一列(Rows(1))，尋找年份
    
11.             If Not r Is Nothing And Not c Is Nothing Then '代號和年份都找到才執行
    
12.                 rng.Offset(, 2) = AA.Cells(r.Row, c.Column) '把找到的座標上的值貼到 rng(A欄) 後的第二欄(C欄)
    
13.             End If
    
14.             Set r =Nothing
    
15.             Set c=Nothing
    
16.         Next
    
17.     End With
    
18. End Sub

複製代碼

markbaseball

回復 2# lpk187


    請問一下，我工作表1的年份其實是循環的，因為不只一種資料需要查找。
    例如說:  2010 2012 2013 2014 2015 2010 2012 2013 2014 2015 一直循環下去。這樣的話，查詢row該怎麼修改呢?

lpk187

回復 3# markbaseball

不好意思！我不懂你的年份循環是什麼意思，延續嗎？
我先假設是延續好了，上述程序的Set c = AA.Rows(1).Find(rng.Offset(, 1), LookIn:=xlFormulas)
就是查找年份，只要是你的年份都放在第一列(整列)，都可以找到。如果年份放在第二列，則 AA.Rows(1)改成 AA.Rows(2)，依此類推
你的問題中有2個條件，一個是找年份，一個是找代號，年份是找第一列(整列)，代號則是找A欄(整欄)

若仍有問題，建議上傳檔案

markbaseball

下載 (166.52 KB)

2016-10-18 11:27

回復 4# lpk187

sheet1長的是像這樣

lpk187

回復 5# markbaseball


    呃！那工作表2呢？不能上傳檔案嗎？為了回答你的問題，回答的人還得作一個和你一樣的活頁簿？
這樣不一定能符合你的需求的！
還有一次說清楚你的需求是什麼，你的圖片和一樓的問題有點不一樣了！

markbaseball

回復 6# lpk187

因為無法直接貼檔案連結，故放在txt檔，以壓縮檔上傳連結
檔案連結.rar (148 Bytes)

下載次數: 6

2016-10-18 12:29

lpk187

回復 7# markbaseball

1. Sub ro()
   
2.     Dim ro As Range, co As Range
   
3.     Dim AA As Worksheet, bb As Worksheet
   
4.     Dim rng As Range, r As Range, shco As Range
   
5.     Dim crng As Range, ng As Range
   
6.     Set AA = Worksheets("工作表1")
   
7.     Set bb = Worksheets("工作表2")
   
8.     Set ro = bb.[D65535].End(xlUp)
   
9.     Set co = bb.[E1].End(xlToRight)
   
10.     Set shco = AA.[c1].End(xlToRight)
    
11.     For Each rng In bb.Range("D2", ro.Address)
    
12.         If rng <> "" Then
    
13.         Set r = AA.Columns(2).Find(rng, LookIn:=xlFormulas)
    
14.         For Each crng In bb.Range("e1", co)
    
15.             For Each ng In AA.Range("c1", shco.Address)
    
16.                 If ng.Value & ng.Offset(1).Value Like rng.Offset(, -2) & crng.Value & "*" Then
    
17.                     If Not r Is Nothing And Not ng Is Nothing Then
    
18.                         bb.Cells(rng.row, crng.column) = AA.Cells(r.row, ng.column)
    
19.                     End If
    
20.                     Exit For
    
21.                 End If
    
22.             Next
    
23.         Next
    
24.         Set r = Nothing
    
25.         End If
    
26.     Next
    
27. End Sub

複製代碼

markbaseball

回復 8# lpk187


    太厲害了!!不過可以請大大稍微解說一下嗎?
             For Each crng In bb.Range("e1", co)
             For Each ng In AA.Range("c1", shco.Address)
            這裡看不適頗懂耶!

lpk187

回復 9# markbaseball

上述程序代碼都是很基礎的語句，若你有善用區域變數視窗以及F8(逐步執行)來觀看其代碼的話。其實不用解釋，
就可以很容易的觀察其程序的內容以及意思，會比我解釋，更容易理解！！
以下代碼為了解釋，修改了變數名稱(容易觀看)，其內容也有做稍微的修正。

1. Sub ro()
   
2.     Dim sht2EndRow As Range, sht2EndColumn As Range
   
3.     Dim sht_1 As Worksheet, sht_2 As Worksheet
   
4.     Dim rng As Range, findCusIP As Range, sht1EndColumn As Range
   
5.     Dim crng As Range, ng As Range
   
6.     Set sht_1 = Worksheets("工作表1")
   
7.     Set sht_2 = Worksheets("工作表2")
   
8.     Set sht2EndRow = sht_2.[D65535].End(xlUp) '找 工作表2 的 D欄 最後一儲存格，其語句的意思為：從儲存格的D65535往上找，找到有值的儲存格，這裡一定要往上找，因為D欄為不連續的範圍(有空的儲存格)，
   
9.     Set sht2EndColumn = sht_2.[E1].End(xlToRight) '找 工作表2 的 第一列 的最後一儲存格，其語句的意思為：從 E1 往右找到最後有值的儲存格
   
10.     Set sht1EndColumn = sht_1.[c1].End(xlToRight) '找 工作表1 的 第一列 的最後一儲存格
    
11.    
    
12.     For Each rng In sht_2.Range("D2", sht2EndRow) '以工作表2的 D2 到 D欄 最後一儲存格的範圍做迴圈循環，這裡指向的範圍是 D2:D1068
    
13.         If rng <> "" Then '如果 目標儲存格 rng 不為空值才執行內部語句
    
14.             Set findCusIP = sht_1.Columns(2).find(rng, LookIn:=xlFormulas) '先找到 CusIP 在B欄的哪一 列 的儲存格
    
15.             If Not findCusIP Is Nothing Then '如果有找到 CusIP才執行下列語句
    
16.                 For Each crng In sht_2.Range("e1", sht2EndColumn) '以工作表2 的 第一列 從 E1 到 第一列 的最後一儲存格的範圍做迴圈循環，這裡指向的範圍是 E1:I1
    
17.                     ''''''下面迴圈開始尋找
    
18.                     For Each ng In sht_1.Range("c1", sht1EndColumn) '以工作表1 的 C1:KT1 做範圍 比對年份以及其下一格的儲存格內容，比如：1978Return on Equity[Y78]
    
19.                         ''''''下列的 ng.Value & ng.Offset(1).Value(工作表1的 年份和名稱) 和 rng.Offset(, -2) & crng.Value & "*"(工作表2的年份和名稱) 做比對
    
20.                         ''''''這裡的 "*" 是把工作表1的第二列名稱中的中括號以及其內容去除掉(說是去除掉，但應該說可以是任何的內容)
    
21.                         If ng.Value & ng.Offset(1).Value Like rng.Offset(, -2) & crng.Value & "*" Then
    
22.                             sht_2.Cells(rng.row, crng.column) = sht_1.Cells(findCusIP.row, ng.column) '比對成功後寫入儲存格，比如說 E2、F2、G2、H2、I2 依此類推
    
23.                             Exit For
    
24.                         End If
    
25.                     Next
    
26.                     '''''''''''''
    
27.                 Next
    
28.             End If
    
29.             Set findCusIP = Nothing '當次的迴圈結束後，設定為沒有物件，以利下個迴圈搜尋，沒設的話，則有可能找到錯誤的資料
    
30.         End If
    
31.     Next
    
32. End Sub

複製代碼