CODEWITHSUNDEEP
vbaexcelmacros
guarcleveland
guarcleveland

Reputation: 1

Need more efficiency than For Each Loop vba

I am a newcomer to vba/excel macros and need a more efficient way to run the below code. I am using a for each loop to return a value from a row based on a column's value (same row). The code works, but takes far too much processing power and time to get through the loops (often freezing the computer or program). I would appreciate any suggestions...

'The following is searching each cell in a range to determine if a cell is not empty. If the cell is not empty, the macro will copy the value of the cell and paste it in to another worksheet (same row)

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

'The following is searching each cell in a range to determine if a cell contains a "T". If the cell contains a "T", the macro will copy the value of a different column (same row) and paste it in to another worksheet (same row)

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

Upvotes: 0

Views: 446

Answers (3)

user3598756
user3598756

Reputation: 29421

as for your first copy/paste values, it actually doesn't need any check, since blank values would be pasted as blank ones...

so you could go:

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

as for your 2nd copy/paste values, you could paste all values and then filter not wanted ones and clear them in target sheet like follows:

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

that said, if your workbook has many formulas and/or event handlers then you would also greatly benefit from disabling them (Application.EnableEvents = False, Application.Calculation = xlCalculationManual) before running your code and enabling them back (Application.EnableEvents = True, Application.Calculation = xlCalculationAutomatic) after you code completes

Upvotes: 0

Ambie
Ambie

Reputation: 4977

If you just want a straight data transfer (ie no formulas or formats), and your data set is large, then you could consider writing the data in one batch by way of an array.

Your own code shouldn't be horrendously slow though, so it suggests you have some calculations running or maybe you're handling Worksheet_Change events. If this is possible, then you might want to disable those during the data transfer:

With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Just remember to reset them at the end of your routine:

With Application
    .EnableEvents = True
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

If you went the array route, skeleton code would be like so:

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

Upvotes: 1

A.S.H
A.S.H

Reputation: 29332

A formula array should be your best hope. This supposes that the cells that do not match will lead to empty values in the destination range:

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

Not sure that it will be faster with your dataset though, you can only verify by trying it.

Upvotes: 1

Related Questions