查找和复制代码

对的人，我又回来了一些更多的帮助。 我有一本工作手册，每个月都会添加新的工作表，其结构信息与以前完全一样。 在A栏中，我有发票号码，然后列B：J的详细信息。 在K＆L列中，为所有未解决的问题手动添加注释。 我想要做的是能够在最后一张工作表中查找发票，然后将K＆L列中的注释复制到新的工作表中。

我试图创build一些代码，但没有什么是脱落的。 ActiveSheet是没有评论的新创build的。 所以我想在列A中查找发票号码，并将从最后一张工作表中find匹配的列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 

Answer 1

你在前面的表单中有一个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 

Answer 2

我的build议是，您的VBA代码放在新工作表中的VLOOKUP公式检索发票信息，如下所示：

activesheet.Cells(cel.Row, 11).formula="=VLOOKUP(...)"

那么为了用你的代码可以使用的文本replace公式

activesheet.Cells(cel.Row, 11).Copy

其次是

activesheet.Cells(cel.Row, 11).PasteSpecial xlPasteValues用文本值replace公式

试试我的代码

  ' 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是正确的行列，让我们知道你如何得到

菲利普