[發問] 不同sheet之間抓取資料

ldneye

最近剛接觸VBA 所以有些東西還不是很熟
下面這個問題我google一天了還是找不到解決的辦法




我有兩個column 的資料 ( 文字)   分別在不同的工作表

sheet1 :   a
                   b
                   c
                   d
                   e
                   f   

sheet2 : a
                 1 2 3 4 5
                 6 7 8 9 10
                 b
                 1 2 3 4 5
                 6 7 8 9 10
                 c
                1 2 3 4 5
                6 7 8 9 10
               e
               1 2 3 4 5
               6 7 8 9 10
               11 12  13  14 15
               f
               1 2 3 4 5
               6 7 8 9  1
               1  12  6  74  8

我想要是設一個迴圈

if sheet1.range("A" & i) = sheet2.range("A" & j )

copy  sheet2.range("A2 : E2")
paste in sheet1.range("B1 :E1")


...

( 也就是在sheet2裡的 a的下面的 1 2 3 4 5 要貼到 sheet1 a 的左邊 ,

  最後迴圈跑完的結果在sheet1是 :

a 1 2 3 4 5
b 1 2 3 4 5
c 1 2 3 4 5
d 1 2 3 4 5
e 1 2 3 4 5
f 1 2 3 4 5

這樣講不知道清不清楚

如果有疑問我還可以再補充

請各位大大教我一下怎麼寫這段程式吧

謝謝


我想要是設一個迴圈

yuhuahsiao

回復 1# ldneye


    請問sheet2
         a
         12345
          678910

都是在 A欄嘛 ?  
A1
A2
A3
或是  是
A1
A2 B2 C2 D2 E2
.....

ldneye

A1
A2 B2 C2 D2 E2

genes

回復 3# ldneye


    請附上檔案

ldneye

回復 4# genes

Private Sub CommandButton1_Click()

Sheets("Return").Select
finalrow = ActiveSheet.UsedRange.Rows.Count
Sheets("2006_1").Select
finalrow06 = ActiveSheet.UsedRange.Rows.Count

For j = 2 To finalrow06
For i = 1 To finalrow -5

If Sheets("2006_1").Cells(1, j) = Sheets("Return").Cells(1, i) Then
S
heets("Return").Select
Sheets("Return").Range(Range("A" & i + 2), Range("A" & i + 2).Offset(0, 12)).Copy

With Sheets("2006_1")
     .Select
     .Range(Range("B" & j), Range("B" & j).Offset(0, 12)).Select
End With
   
ActiveSheet.Paste
Sheets("2006_1").Select
End If
Next
Next

End Sub

ldneye

抱歉  
If Sheets("2006_1").Cells(1, j) = Sheets("Return").Cells(1, i) Then

應該是

If Sheets("2006_1").Cells(j,1) = Sheets("Return").Cells( i,1) Then

ldneye

example.rar (117.51 KB)

example
下載次數: 23

2013-11-4 00:53

回復 4# genes




謝謝版主提醒 因為我還不太習慣這個版的版規  如有觸犯 請多包涵

已經附上檔案了

我想要把第二個sheet ( Return) 裡面 2005 年的 return ,  一月份到十二月份的資料  複製貼上到  sheet( 2006_1)  對應到相同名字的 右邊

我的程式碼不知到哪邊出了問題

上網看了很久也看不出個所以然來

所以想請各位網路上好心的大大指點迷津

謝謝

如果還有觸犯版規的地方也請不吝告知 我會遵守的

genes

回復 7# ldneye

放到module上
2張worksheets公司名不對稱,自己改下code吧

1. Option Explicit
   
2. Sub test1()
   
3. Dim finalrow As Integer
   
4. Dim finalrow06 As Integer
   
5. Dim j As Integer
   
6. Dim i As Integer
   
7. finalrow = Sheets("Return").UsedRange.Rows.Count
   
8. finalrow06 = Sheets("2006_1").UsedRange.Rows.Count
   
9. With ActiveWorkbook
   
10. For j = 2 To finalrow06
    
11. For i = 1 To finalrow - 5
    
12. 
    
13. If .Sheets("2006_1").Cells(j, 1).Value = .Sheets("Return").Cells(i, 1).Value Then
    
14. 
    
15. 'Sheets("Return").Select
    
16. .Sheets("Return").Range(Cells(i + 2, 1), Cells(i + 2, 13)).Copy Destination:=.Sheets("2006_1").Range("B" & j)
    
17. End If
    
18. Next
    
19. Next
    
20. End With
    
21. End Sub

複製代碼

ldneye

感謝前輩，我知道我的錯在哪裡了，就是公司名稱不對。
我以為 兩個cells 裡面的文字不用完全一樣只要相似就可以複製貼上( 甚至連前面有空格都不行 = = )

還有一個問題
就是我是想要把每間公司2005年的資料複製貼上到sheets 2006
但是由於他每個公司的資料開始的時間都不一樣 ，有的是從2002年開始 ，有的是從2005年開始
，甚至有的沒有資料！ 沒有辦法用 row + i 的方式推算出來，不知道前輩有沒有什麼更好的方法呢?
謝謝囉

GBKEE

回復 9# ldneye
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim e As Range, Rng(1 To 2) As Range
   
4.     Sheets("2006_1").Range("B:O").Clear
   
5.     For Each e In Sheets("2006_1").Range("a:a").SpecialCells(xlCellTypeConstants)
   
6.         If Trim(e) <> "" Then   '排除有輸入空白字串的儲存格
   
7.             'Trim(e) -- LTrim、RTrim 與 Trim 函數    傳回一個沒有前頭空白 (LTrim)、後面空白 (RTrim) 或前後均無空白的Variant (String)，其中所含為給定的字串。
   
8.             Set Rng(1) = Sheets("Return").Range("a:a").Find(e, lookat:=xlPart)
   
9.             If Not Rng(1) Is Nothing Then
   
10.                 Set Rng(2) = Rng(1).CurrentRegion.Columns(1).Find("2005", lookat:=xlWhole)
    
11.                 If Not Rng(2) Is Nothing Then e.Offset(, 1).Resize(, 14) = Rng(2).Resize(, 14).Value
    
12.             End If
    
13.         End If
    
14.     Next
    
15. End Sub

複製代碼