Excel VBA - Loop to check entire column range rather than each cell - vba

Question

I have written a script which checks a range of cells in column range 4 (Column D) for non-blank values, if it finds a non blank value, it copies that value and pastes it to a cell in column range 6 (Column F). The script runs, but it is awfully slow, the script takes 5 minutes to process and complete its run. Is there any way to improve this script so that it can pre-check the range before it copies and pastes the values across? It seems that the copy / paste function is slowing it down.
Code below
Sub ArrayCopyPaste()
Dim J as Integer
Application.Calculation = xlCalculationManual
For J = 2 To 500
If Cells(J, 4).Value <> "" Then
Cells(J, 4).Copy
Cells(J, 6).PasteSpecial Paste:=xlPasteValues
End If
Next J
Application.Calculation = xlCalculationAutomatic
End Sub

Answer 1

Here's one way:
Sub test()
Dim r1, r2, n As Long
With Sheets("Sheet1") '~~> change to suit
Dim lrow As Long
lrow = .Range("D" & .Rows.Count).End(xlUp).Row
r1 = Application.Transpose(.Range("D2:D" & lrow))
r2 = Application.Transpose(.Range("F2:F" & lrow))
For n = LBound(r1) To UBound(r1)
If r1(n) <> "" Then r2(n) = r1(n)
Next
.Range("F2:F" & lrow) = Application.Transpose(r2)
End With
End Sub
Transfer range data to array, then do the comparison process array to array.
Then return the array to range. HTH.
Important: Application.Transpose have limitation. I can handle only a few thousand data.
Follow up: Try this for deleting
Dim rngToDelete As Range, k As Long
With Sheets("Sheet1") '~~> change to suit
For k = 2 To 500
If .Cells(k, 6).Value = "" Then
If rngToDelete Is Nothing Then
Set rngToDelete = .Cells(k, 6)
Else
Set rngToDelete = Union(rngToDelete, .Cells(k, 6))
End If
End If
Next
rngToDelete.Delete xlUp
'rngToDelete.EntireRow.Delete xlUp ~~> use this if you want to delete entire row.
End With
Determine all the target range first then delete in one go. HTH.

Answer 2

Try simply doing this first and see if it makes a difference:
Dim currentCalculation As Variant
currentCalculation = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For J = 2 To 500
If Cells(J, 4).Value <> "" Then
Cells(J, 4).Copy
Cells(J, 6).PasteSpecial Paste:=xlPasteValues
End If
Next J
Application.ScreenUpdating = True
Application.Calculation = currentCalculation
Another thought. Have you tried just doing this?
For J = 2 To 500
If Cells(J, 4).Value <> "" Then
Cells(J, 6).Value = Cells(J, 4).Value
End If
Next J

Answer 3

It won't make any difference to your target column if the blanks are copied, so don't bother checking for them. Don't loop -- just copy the entire column.
Sub CopyColumn()
' copying this way does not use your clipboard
Columns("D").Copy Columns("F")
End Sub
If you only need a portion of the column, specify the range to copy rather than the entire column:
Sub CopyPartOfColumn()
' copying this way does not use your clipboard
Range("D2:D500").Copy Range("F2:F500")
End Sub
You mention in a comment below your question that you want the resulting column to be a consolidated list of the values without the blanks. You can quickly do that by deleting the blanks from the column or range, once again without looping. Run this after you've copied the values you want.
Sub RemoveBlanks()
Range("F2:F500").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End Sub