在多列下查找，复制和粘贴值

下面的代码是将sheet1中的“Apple”列下的值复制到sheet2中的“AppleNew”列中。 （感谢Tim）

但是，如果我有多列（橙，香蕉等）是有办法编写更简单的代码，通过循环的sorting，而不是复制和粘贴每列的代码？

Dim rng as range, rngCopy as range, rng2 as range set rng = Sheet1.Rows(3).Find(What:="Apple", LookIn:=xlValues, LookAt:=xlWhole) if not rng is nothing then set rngCopy = Sheet1.range(rng.offset(1,0), _ Sheet1.cells(rows.count,rng.column).end(xlUp)) set rng2 = Sheet2.Rows(1).Find(What:="AppleNew", LookIn:=xlValues, _ LookAt:=xlWhole) if not rng2 is nothing then rngCopy.copy rng2.offset(1,0) end if 

Answer 1

 sub Tester() DoColumnCopy "Apple", "AppleNew" DoColumnCopy "Apple2", "Orange" end sub sub Tester2() dim i, arrFrom, arrTo arrFrom = Array("Apple","Apple2") 'source cols arrTo=Array("AppleNew","Orange") 'destination cols for i=lbound(arrFrom) to ubound(arrFrom) DoColumnCopy Cstr(arrFrom(i)), Cstr(arrTo(i)) 'EDIT: pass as strings next i end sub Sub DoColumnCopy(FromColName as string, ToColName as string) Dim rng as range, rngCopy as range, rng2 as range set rng = Sheet1.Rows(3).Find(What:=FromColName , LookIn:=xlValues, _ LookAt:=xlWhole) if not rng is nothing then set rngCopy = Sheet1.range(rng.offset(1,0), _ Sheet1.cells(rows.count,rng.column).end(xlUp)) set rng2 = Sheet2.Rows(1).Find(What:=ToColName , LookIn:=xlValues, _ LookAt:=xlWhole) if not rng2 is nothing then rngCopy.copy rng2.offset(1,0) end if end sub 

Answer 2

 Dim varColName As Variant For Each varColName In Array("Orange", "Banana", "Pear") 'Your code goes here 'In your code, replace "Apple" with varColName 'In your code, replace "AppleNew" with varColName & "New" Next varColName