12
返回列表 上一主題 發帖

excel vba 查找

markbaseball

帖子
6 
主題
2 
精華
0 
積分
8 
點名
0  
作業系統
win10 
軟體版本
office2013 
閱讀權限
10 
註冊時間
2016-4-12 
最後登錄
2016-12-23 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2016-10-17 10:13 | 只看該作者

excel vba 查找

(工作表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
收藏 分享

hcm19522

帖子
1387 
主題
4 
精華
0 
積分
1397 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2024-11-22 

熱烈參與勳章
13#
發表於 2022-4-9 14:38 | 只看該作者
https://blog.xuite.net/hcm19522/twblog/590330682
google"EXCEL迷"  blog  或google網址:https://hcm19522.blogspot.com/

TOP

laiglook

帖子
1 
主題
0 
精華
0 
積分
5 
點名
0  
作業系統
WIN10 
軟體版本
1903 
閱讀權限
10 
註冊時間
2019-7-8 
最後登錄
2022-4-8 
12#
發表於 2022-4-8 17:29 | 只看該作者
很厲害的邏輯

TOP

cjw

帖子
6 
主題
0 
精華
0 
積分
19 
點名
0  
作業系統
windows xp 
軟體版本
office 2003 
閱讀權限
10 
性別
男 
來自
台灣台中 
註冊時間
2016-10-24 
最後登錄
2017-8-22 
11#
發表於 2016-10-25 11:26 | 只看該作者
Sub 查找()
Dim xR%, xY%, zR%, j%, xC%
Set SH1 = Sheet1
Set SH2 = Sheet2
xR = SH1.Cells(Rows.Count, "A").End(3).Row
xY = SH1.Cells(1, Columns.Count).End(xlToLeft).Column
Ar = SH1.Cells(1, 1).Resize(xR, xY)
zR = SH2.Cells(Rows.Count, "A").End(3).Row
With SH2
For j = 2 To zR
xC = SH1.Rows(1).Find(.Cells(j, "B")).Column
.Cells(j, "C") = Application.VLookup(.Cells(j, "A"), Ar, xC, 0)
Next
End With
End Sub
cjw

TOP

lpk187

帖子
552 
主題
3 
精華
0 
積分
578 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2024-7-9 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
10#
發表於 2016-10-19 15:24 | 只看該作者
回復 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
複製代碼

TOP

markbaseball

帖子
6 
主題
2 
精華
0 
積分
8 
點名
0  
作業系統
win10 
軟體版本
office2013 
閱讀權限
10 
註冊時間
2016-4-12 
最後登錄
2016-12-23 
9#
發表於 2016-10-18 23:35 | 只看該作者
回復 8# lpk187


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

TOP

lpk187

帖子
552 
主題
3 
精華
0 
積分
578 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2024-7-9 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
8#
發表於 2016-10-18 15:36 | 只看該作者
回復 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
複製代碼

TOP

markbaseball

帖子
6 
主題
2 
精華
0 
積分
8 
點名
0  
作業系統
win10 
軟體版本
office2013 
閱讀權限
10 
註冊時間
2016-4-12 
最後登錄
2016-12-23 
7#
發表於 2016-10-18 12:30 | 只看該作者
回復 6# lpk187

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

TOP

lpk187

帖子
552 
主題
3 
精華
0 
積分
578 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2024-7-9 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
6#
發表於 2016-10-18 11:38 | 只看該作者
本帖最後由 lpk187 於 2016-10-18 11:44 編輯

回復 5# markbaseball


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

TOP

markbaseball

帖子
6 
主題
2 
精華
0 
積分
8 
點名
0  
作業系統
win10 
軟體版本
office2013 
閱讀權限
10 
註冊時間
2016-4-12 
最後登錄
2016-12-23 
5#
發表於 2016-10-18 11:27 | 只看該作者
回復 4# lpk187

sheet1長的是像這樣

TOP

        靜思自在 : 君子立恆志，小人恆立志。
12
返回列表 上一主題