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

Question

我是vba / excel宏的新手，需要一種更有效的方式來運行以下代碼。 我正在為每個循環使用，以根據列的值（同一行）從行返回一個值。 該代碼可以工作，但是要花費太多的處理能力和時間才能完成循環（通常會凍結計算機或程序）。 我將不勝感激任何建議...

'以下是搜索范圍內的每個單元格以確定一個單元格是否不為空。 如果該單元格不為空，則宏將復制該單元格的值並將其粘貼到另一個工作表中（同一行）

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("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 ）