Question

我是vba / excel宏的新手，需要一种更有效的方式来运行下面的代码。我使用a for each循环根据列的值（同一行）从一行返回一个值。代码可以工作，但是需要太多的处理能力和时间来完成循环（通常会冻结计算机或程序）。我很感激任何建议......

'以下是搜索范围中的每个单元格以确定单元格是否为空。如果单元格不为空，宏将复制单元格的值并将其粘贴到另一个工作表（同一行）

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

'以下是搜索范围中的每个单元格以确定单元格是否包含“T”。如果单元格包含“T”，则宏将复制不同列（同一行）的值并将其粘贴到另一个工作表（同一行）

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

Answer 1

公式数组应该是你最好的希望。这假设不匹配的单元格将导致目标范围中的空值：

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

不确定数据集会更快，但您只能通过尝试来验证。

Answer 2

如果您只想进行直接数据传输（即没有公式或格式），并且数据集很大，那么您可以考虑通过数组一批编写数据。

你自己的代码不应该非常慢，所以它建议你运行一些计算，或者你正在处理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

Answer 3

对于您的第一个复制/粘贴值，它实际上不需要任何检查，因为空白值将被粘贴为空白值...

所以你可以去：

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 = False

说，如果你的工作簿有很多公式和/或事件处理程序，那么在运行代码并启用它们之前，你也可以从禁用它们（Application.Calculation = xlCalculationManual，Application.EnableEvents = True）中获益匪浅（{{代码完成后，1}}，Application.Calculation = xlCalculationAutomatic）

需要比For Each Loop vba更高的效率

3 个答案: