需要比For Each Loop vba更高的效率
我是vba / excelmacros的新手，需要更高效的方式来运行下面的代码。 我正在使用一个for循环根据列的值（同一行）从一行返回一个值。 代码工作，但需要太多的处理能力和时间来通过循环（通常冻结计算机或程序）。 我将不胜感激任何build议…
'以下是search范围内的每个单元格，以确定单元格是否不是空的。 如果单元格不为空，则macros将复制单元格的值并将其粘贴到另一个工作表（同一行）
Set rng = Worksheets("Demographic").Range("AU2:AU" & lastRow) i = "2" For Each cell In rng If Not IsEmpty(cell.Value) Then Sheets("Demographic").Range("AU" & i).Copy Sheets("Employee import").Range("F" & i).PasteSpecial xlPasteValues End If i = i + 1 Next '以下是search范围内的每个单元格，以确定一个单元格是否包含“T”。 如果单元格包含“T”，macros将复制不同列（同一行）的值并将其粘贴到另一个工作表（同一行）
Set rng = Worksheets("Demographic").Range("AM2:AM" & lastRow) i = "2" For Each cell In rng If cell.Value = "T" Then Sheets("Demographic").Range("AO" & i).Copy Sheets("Employee import").Range("G" & i).PasteSpecial xlPasteValues End If i = i + 1 Next
公式数组应该是你最好的希望。 这假设不匹配的单元格将导致目标范围内的空值：
chk = "Demographic!AU2:AU" & lastRow src = "Demographic!AU2:AU" & lastRow With Sheets("Employee import").Range("F2:F" & lastRow) .FormulaArray = "=IF(" & chk & "<> """"," & src & ", """")" .Value = .Value '<-- if you want to remove the formulas and keep only the copied values End With chk = "Demographic!AM2:AM" & lastRow src = "Demographic!AO2:AO" & lastRow With Sheets("Employee import").Range("G2:G" & lastRow) .FormulaArray = "=IF(" & chk & "= ""T""," & src & ", """")" .Value = .Value '<-- if you want to remove the formulas and keep only the copied values End With
不知道数据集的速度会更快，只能通过尝试进行validation。
如果你只是想要一个直接的数据传输（即没有公式或格式），并且你的数据集很大，那么你可以考虑以一个数组的方式写入数据。
你自己的代码不应该太慢，所以它表明你有一些计算运行，或者你正在处理Worksheet_Change事件。 如果这是可能的，那么你可能想在数据传输过程中禁用这些：
With Application .EnableEvents = False .ScreenUpdating = False .Calculation = xlCalculationManual End With
只要记住在程序结束时重置它们：
With Application .EnableEvents = True .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With
如果你去了数组路由，骨架代码将如下所示：
Dim inData As Variant Dim outData() As Variant Dim r As Long 'Read the demographic data With Worksheets("Demographic") inData = .Range(.Cells(2, "AU"), .Cells(.Rows.Count, "AU").End(xlUp)).Value2 End With 'Use this if your column F is to be entirely overwritten ReDim outData(1 To UBound(inData, 1), 1 To UBound(inData, 2)) 'Use this if you have exisiting data in column F 'With Worksheets("Employee import") ' outData = .Cells(2, "F").Resize(UBound(inData, 1)).Value2 'End With 'Pass the values across For r = 1 To UBound(inData, 1) If Not IsEmpty(inData(r, 1)) Then outData(r, 1) = inData(r, 1) End If Next 'Write the new values Worksheets("Employee import").Cells(2, "F").Resize(UBound(outData, 1)).Value = outData
至于你的第一个复制/粘贴值，它实际上不需要任何检查，因为空白值将被粘贴为空白的值…
所以你可以去：
With Worksheets("Demographic") With .Range("AU2", .Cells(.Rows.count, "AU").End(xlUp)) Worksheets("Employee import").Range("F2").Resize(.Rows.count).Value = .Value End With End With
至于你的第二个复制/粘贴值，你可以粘贴所有的值，然后过滤不想要的，并在目标表中清除它们，如下所示：
With Worksheets("Demographic") With .Range("AM2", .Cells(.Rows.count, "AM").End(xlUp)) Worksheets("Employee import").Range("G2").Resize(.Rows.count).Value = .Offset(, 2).Value End With End With With Worksheets("Employee import") With .Range("G1", .Cells(.Rows.count, "G").End(xlUp)) .AutoFilter field:=1, Criteria1:="<>T" .Resize(.Rows.count).Offset(1).SpecialCells(xlCellTypeVisible).ClearContents End With .AutoFilterMode = False End With
这就是说，如果你的工作簿有很多公式和/或事件处理程序，那么在运行你的代码并将其启用之前（ Application.EnableEvents = True ），禁用它们（ Application.EnableEvents = False ， Application.Calculation = xlCalculationManual ） ，代码完成后， Application.Calculation = xlCalculationAutomatic ）