[發問] 請教如何讓VBA自動比對相同數值後,複製到它處?

jonn0510

請教老師:
儲存格E 若等於 儲存格C 時,則複製("B:H") 到M3 如何用VBA來判斷?謝謝
如附件
B      C    D     E      F      G    H
1        17        -6        06        07        16        20
2        14        -6        06        11        16        20
3        26        -5        26        06        16        20
4        20        -9        06        16        22        27
5        17        -6        06        07        16        27
6        17        -6        17        16        20        22
7        -9        -6        06        06        16        31
------------------------------------
B      C    D     E      F      G    H
3        26        -5        26        06        16        20
6        17        -6        17        16        20        22

kimbal

1. Sub test()
   
2.     Dim outRow As Long
   
3.     outRow = 0
   
4.     For Each C In Range(Range("C3"), Range("C3").End(xlDown))
   
5.         If C.Value = C.Offset(0, 2) Then
   
6.             Range(C.Offset(0, -1), C.Offset(0, 5)).Copy
   
7.             Range("M3").Offset(outRow).PasteSpecial
   
8.             outRow = outRow + 1
   
9.         End If
   
10.     Next
    
11. End Sub

複製代碼

其實,可以考慮一下用篩選 復制方法, 不用慢慢對代碼

jonn0510

回復 2# kimbal
kimbal老師:
感謝您的指導,謝謝您
另外您提到"其實,可以考慮一下用篩選 復制方法, 不用慢慢對代碼".原本有打算用篩選,但是資料很龐大,且經常會用到,於是想一勞永逸.所以才會上網請教.

非常感謝您

diabo

回復 3# jonn0510

資料龐大可以考慮 SQL 的做法  
記得
1. 設定引用項目 Microsoft ActiveX Data Objects 2.8 Library
2. Sheet1的B2:H2 空白的補上欄位名稱...

1. Sub test()
   
2. 
   
3. '建立ADODB Connection物件變數
   
4. Dim cn As ADODB.Connection
   
5. Set cn = New ADODB.Connection
   
6. 
   
7. '建立ADODB Recordset物件變數
   
8. Dim rs As ADODB.Recordset
   
9. Set rs = New ADODB.Recordset
   
10.          
    
11. '建立資料庫連線
    
12. With cn
    
13.      .Provider = "MSDASQL"
    
14.      .ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & _
    
15.       "DBQ=" & ThisWorkbook.FullName & ";"
    
16.      .Open
    
17. End With
    
18. 
    
19. 'SQL字串
    
20. mySQL = "Select * FROM [Sheet1$B2:H25] WHERE [主]=[副]"
    
21.      
    
22. '解決無法釋放記憶體的BUG
    
23. ThisWorkbook.ChangeFileAccess xlReadOnly
    
24. Set rs = cn.Execute(mySQL)
    
25. ThisWorkbook.ChangeFileAccess xlReadWrite
    
26.          
    
27. '將結果COPY到指定位置
    
28. Sheets("Sheet1").Range("M12").CopyFromRecordset rs
    
29. 
    
30. End Sub

複製代碼

jonn0510

回復 4# diabo

diabo大大:
不好意思,這麼久才回覆,因為小弟不太能理解 所謂的 SQL 的做法,因此去查了一下書.
可惜有看沒有懂!不過還是要感謝您願意提供方案.謝謝您