循环查看某个单元格是否为空，如果不是，则转到单元格中引用的页面并执行一些复制/粘贴
我需要一些帮助来浓缩我的代码。 我为我公司的订单和发票创build了一个相当大的电子表格。 由于其大小和代码量，执行速度非常慢。
编码我想一些帮助，首先在当前活动行的列A和B中的复制单元格，然后通过使用列“A”是当前活动单元格的行来查看行。 它需要find一个产品参考产品库存页面，单元格将从13开始偏移，它会激活产品的页面，并将复制的单元格粘贴到一个表格，注意范围“F4”，但它那么需要查看一下订单页面上是否有另一个产品，每次都会有一个偏移量为2。 以下是我目前的代码，任何见解都会非常有帮助
If Not neworder.cbotype.Value = "L-Wholesale-Abbas" Then If Not neworder.cbotype.Value = "V-Wholesale-Abbas" Then '(1) Sheets("Orders").Select ActiveCell.Select ActiveCell.Resize(1, 2).Select Selection.Copy ActiveCell.Offset(0, 13).Select Worksheets(ActiveCell.Value).Activate lRow = ActiveSheet.Range("f4").CurrentRegion.Rows.Count With ActiveSheet.Range("f4") Range("f4").Select Selection.End(xlDown).Select .Offset(lRow, 0).Select Selection.PasteSpecial Range("h2:i2").Copy .Offset(lRow, 2).PasteSpecial End With '(2) On Error Resume Next Sheets("Orders").Select ActiveCell.Select If Not IsEmpty(ActiveCell.Offset(0, 2)) Then ActiveCell.Offset(0, -13).Select ActiveCell.Resize(1, 2).Select Selection.Copy ActiveCell.Offset(0, 15).Select Worksheets(ActiveCell.Value).Activate lRow2 = ActiveSheet.Range("f4").CurrentRegion.Rows.Count With ActiveSheet.Range("f4") Range("f4").Select Selection.End(xlDown).Select .Offset(lRow2, 0).Select Selection.PasteSpecial Range("h2:i2").Copy .Offset(lRow2, 2).PasteSpecial End With Else End If 然后继续（2）重复（50）
下面是这个代码工作的订单页面的一行，我在两个空的列中放置了一个“x”，我的代码正在寻找的单元格是最后一个单元格，有物品数量，然后物品参考重复了50次
1-Jun VK-LG-3224_1 Dropship Bellezza scarf rahima begum Seller £7.00 PayPal £6.56 xx 1 VIVK-N-NP-203 1 VIVK-N-NP-197
步骤：1）复制最后一行中的单元格A和B 2）在列N中打开表单名称3）从表格F4开始粘贴到最后一行4）返回到订单单5）将单元格A和B复制到同一行6）在列P中打开表格名称7）从表格F4开始粘贴最后一行
这继续沿着同一行，一次移动两列，直到最后一列是DH
下面的代码将执行以下操作：
-
复制
Order表最后一行中的A和B单元格中的文本 -
然后，它会从
column N到Column N +50该行的每个第二个单元格中查找表名，然后粘贴OrderSheet Cells A and B的值。
信用Rory来检查表单名称的有效性。 从这个答案采取
Option Explicit Sub SearchAndCopy() Dim LastRowOrderSheet As Long Dim OrderSheetColRef As Long Dim OrderSheet As Worksheet Dim LastRowCopyToSheet As Long Dim OrderSheetStartCol As Long Dim OrderCopyRange As Range Dim CopyToSheet As Worksheet Dim CopyToSheetName As String Set OrderSheet = ThisWorkbook.Sheets("Orders") LastRowOrderSheet = OrderSheet.Cells(OrderSheet.Rows.Count, "A").End(xlUp).Row OrderSheetStartCol = 14 With OrderSheet Set OrderCopyRange = .Range(.Cells(1, 1), .Cells(1, 2)) End With For OrderSheetColRef = OrderSheetStartCol To OrderSheetStartCol + 50 Step 2 'Trim to remove any possibly unwanted blank spaces before or after the name CopyToSheetName = Trim(OrderSheet.Cells(LastRowOrderSheet, OrderSheetColRef).Value) 'Ending Loop if there is no name in CopyToSheetName If Trim(CopyToSheetName) = "" Then Exit For End If 'If the SheetName returns back False then the error message appears If Not WorksheetExists(CopyToSheetName) Then MsgBox "Sheet: " & CopyToSheetName & " does not exisit." & vbCr & vbCr & _ "Check Order sheet:" & vbCr & _ "Row: " & LastRowOrderSheet & vbCr & _ "Column: " & OrderSheetColRef End End If Set CopyToSheet = ThisWorkbook.Sheets(CopyToSheetName) With CopyToSheet LastRowCopyToSheet = .Cells(.Rows.Count, "F").End(xlUp).Row '+1 because the lastrow plus 1 is the next empty row .Range(.Cells(LastRowCopyToSheet + 1, "F"), _ .Cells(LastRowCopyToSheet + 1, "G")) = OrderCopyRange.Value 'Copy formulas from CopyTSheet H2:I2 to the adjacent cells on right of new data in CopyToSheet .Range("H2:I2").Copy .Range(.Cells(LastRowCopyToSheet + 1, "H"), _ .Cells(LastRowCopyToSheet + 1, "I")) End With Next OrderSheetColRef End Sub
请在您的代码的开头添加如下内容：
Application.Calculation = xlCalculationManual Application.ScreenUpdating = False
最后：
Application.Calculation = xlCalculationAuto Application.ScreenUpdating = True
不要使用select！ 定义一个范围variables并引用它
你的代码
ActiveCell.Select ActiveCell.Resize(1, 2).Select Selection.Copy
需要Excel来发现活动单元2次。 代替
DIm r as Range Set r = Activecell r.resize(1,2) r.copy
然后在你的代码使用的开始
Application.ScreenUpdating = False Application.Calculation = XLCalculateManual Application.EnableEvents = False
然后在你的代码使用结束
Application.ScreenUpdating = true Application.Calculation = XLCalculateAutomatic Application.EnableEvents = true