查找和复制代码
问题描述：
对的人，我回来了一些更多的帮助。我有一本工作手册，每个月都会添加新的工作表，其结构信息与以前完全一样。在A栏中，我有发票号码，然后列B：J的详细信息。在K & L列中，为所有未解决的问题手动添加了评论。我想要做的是能够在最后一张工作表中查找发票，然后将注释K & L复制到新工作表中。查找和复制代码
我试图创建一些代码，但没有什么是脱落的。 ActiveSheet是没有评论的新创建的。因此，我想在A列中查找发票编号，并复制列K & L，其中从最后一张工作表中找到匹配的积极表的列K & L.我希望我做的意义，并感谢您帮助
Option Explicit
Sub FindCopy_all()
Dim calc As Long
Dim Cel As Range
Dim LastRow As Long
Dim rFound As Range
Dim LookRange As Range
Dim CelValue As Variant
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of data ActiveSheet, Col A
LastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
' Set range to look in
Set LookRange = ActiveSheet.Range("A1:A" & LastRow)
' Loop on each value (cell)
For Each Cel In LookRange
' Get value to find
CelValue = Cel.Value
' Look on previous sheet
With Sheets(Sheets.Count - 3)
Set rFound = .Cells.Find(What:=CelValue, _
After:=.Cells(1, 1), LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
' Reset
On Error GoTo endo
' Not found, go next
If rFound Is Nothing Then
GoTo NextCel
Else
' Found. last sheet, Col K & L to Active Sheet found Row, Col K & L
.Cells(rFound.Row, 11, 12).Resize(, 2).Copy ActiveSheet.Cells(Cel.Row, 11, 12)
End If
End With
NextCel:
Next Cel
Set rFound = Nothing
'Reset
endo:
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
答
您在前面的纸张上with声明，任何activesheet声明存在。用途：
.Cells(rFound.Row, 11).Resize(,2).Copy activesheet.Cells(cel.Row, 11)
此外，你不应该需要On Error Resume Next返回的将是nothing的范围内，也可以确保您set rFound = nothing您完成后每个找到。
NextCel:
set rFound = nothing
我的代码：
Option Explicit
Sub FindCopy_all()
Dim calc As Long
Dim Cel As Range
Dim LastRow As Long
Dim rFound As Range
Dim LookRange As Range
Dim CelValue As Variant
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of data ActiveSheet, Col A
LastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
' Set range to look in
Set LookRange = ActiveSheet.Range("A1:A" & LastRow)
' Loop on each value (cell)
For Each Cel In LookRange
' Get value to find
CelValue = Cel.Value
' Look on previous sheet
With Sheets(Sheets.Count - 1)
Set rFound = .Range("A:A").Find(What:=CelValue, _
After:=.Cells(1, 1), LookIn:=xlValues, _
Lookat:=xlWhole, MatchCase:=False)
' Not found, go next
If rFound Is Nothing Then
GoTo NextCel
Else
' Found. last sheet, Col K & L to Active Sheet found Row, Col K & L
.Cells(rFound.Row, 11).Resize(, 2).Copy ActiveSheet.Cells(Cel.Row, 11)
End If
End With
NextCel:
Set rFound = Nothing
Next Cel
With Application
.Calculation = calc
.ScreenUpdating = True
End With
End Sub
答
我的建议是，你的VBA代码放在VLOOKUP公式在新的工作表来获取这样的发票信息：
3210
then in orde R键来替换文本公式你的代码可以使用后跟
activesheet.Cells(cel.Row, 11).PasteSpecial xlPasteValues
activesheet.Cells(cel.Row, 11).Copy
只用文字来代替公式值
试试我的代码
' Speed
calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'Get Last row of data ActiveSheet, Col A
LastRow = ActiveSheet.Cells(activesheet.rows.count, 1).End(xlUp).Row
' Set VLOOKUP formula, search on the other sheet for the value in column A, return the value matchiung from column 11, and use EXACT MATCH.
'
' =VLOOKUP(A:A,Sheet1!A:L,11,FALSE) ' example
'
range("K1:K" & lastRow).formula="=VLOOKUP(A:A," & sheets(Worksheets.count-1).name & "!A:L,11, FALSE)"
activesheet.calculate
range("K1:K" & lastRow).copy
range("K1:K" & lastRow).pastespecial xlpastevalues ' remove the formulas
那应该让你开始，尝试一下，并检查VLOOKUP是否正确的列和乐牛逼我们知道你在
菲利普
如何得到的是有一个原因，你不能在你的目标列使用VLOOKUP公式的最后一个工作表上获得的评论数据匹配你想要什么？ – 2013-04-11 14:50:14
唯一的原因是我想让流程自动化，而不是花时间做公式。我为一家拥有电脑文盲助理的小公司工作，最简单的方法是拥有一个VBA代码，只需点击一下按钮即可完成所有工作。 – Werra2006 2013-04-12 07:36:16
好的，但是为什么不在新的表单中添加新的表单时自动化呢，比如'Range（“....”）。formula =“= VLOOKUP（...）”'这样工作就可以通过公式在工作表 – 2013-04-12 10:04:12