I have this code that copying values from column BP to Column BE.
The code copied all values expect those cells that contain “#N/A” and is empty.
This code goes through thousands of data. But, suddenly it take so long for running the code and keep on running for more than half an hour.
Could anyone help me to fix this code? Thank you in advance 🙂
Sub copy()
Dim sortir As Range, g As Range
With ThisWorkbook.Sheets("ALL")
Set sortir = .Range("BP2:BP" & .Range("BP" & .Rows.Count).End(xlUp).Row)
For Each g In sortir
If Not (g.Text = "#N/A" Or IsEmpty(g.Value)) Then
.Cells(g.Row, "BE").Value = .Cells(g.Row, "BP")
End If
Next g
End With
End Sub
Please, try the next code. It uses arrays, all processing is done in memory and processed array content is dropped at once, at the end of the code. So it should be very fast, even for large ranges:
Sub copyCells()
Dim ws As Worksheet, lastR As Long, arrBP, arrBE, i As Long
Const srcCol As String = "BP" 'you can change if needing to insert/delete other columns
Const retCol As String = "BE" 'it can be also changed in the future, if needed
Set ws = ThisWorkbook.Sheets("ALL") 'use here the sheet you need
lastR = ws.cells(ws.rows.count, srcCol).End(xlUp).row
arrBP = ws.Range(ws.cells(2, srcCol), ws.cells(lastR, srcCol)).Value 'place the range in an array for faster iteration
arrBE = ws.Range(ws.cells(2, retCol), ws.cells(lastR, retCol)).Value 'place existing range in an array
For i = 1 To UBound(arrBP)
If Not IsError(arrBP(i, 1)) Then
If arrBP(i, 1) <> "" Then
arrBE(i, 1) = arrBP(i, 1) 'place in the return array the value
End If
End If
Next i
'drop the processed array content, at once:
ws.cells(2, retCol).Resize(UBound(arrBE)).Value = arrBE
MsgBox "Ready..."
End Sub
Plese, send some feedback after testing it.
2
First thing: “Copy” is a Method attached to various Objects in VBA; that makes it a bad choice of Subroutine name.
Next, if you know that things are going to take a while, then you should consider:
- Temporarily turning off Calculation
- Temporarily turning off Screen Updating
- Giving yourself an indication of Progress
- Periodically calling
DoEvents, to check in the OS and not look like you’ve crashed - Alerting yourself when it completes
Sub CopyNonErrors()
Dim ws As Worksheet, sortir As Range, g As Range
Set ws = ThisWorkbook.Sheets("ALL")
Dim dsb As Boolean, sb As Variant, calc As XlCalculation, su As Boolean
su = Application.ScreenUpdating: Application.ScreenUpdating = False
calc = Application.Calculation: Application.Calculation = xlCalculationManual
dsb = Application.DisplayStatusBar: Application.DisplayStatusBar = True
'N.B. This is to prevent VBA from changing the boolean False value inte a "FALSE" string value:
sb = IIf(TypeName(Application.StatusBar) = "Boolean", False, Application.StatusBar)
Dim lCurr As Long, lTotal As Long
'Define 2 corners of a rectangle
Set sortir = ws.Range(ws.Cells(2, "BP"), ws.Cells(ws.Rows.Count, "BP").End(xlUp))
lTotal = sortir.Cells.Count
lCurr = 0
If sortir.Cells(1,1).Row > 1 Then 'Make sure there is ANY data!
For Each g In sortir.Cells
lCurr = lCurr + 1
Application.StatusBar = CStr(lCurr) & " of " & lTotal & " : " & Format(100 * lCurr / lTotal, "#0.00") & "%"
If (lCurr Mod 50) = 0 Then DoEvents
'Checking the Error Value directly, rather than for "#N/A" text
If Not (g.Value = CVErr(xlErrNA) Or IsEmpty(g.Value)) Then
g.EntireRow.Cells(, "BE").Value = g.Value
End If
Next g
End If
'Reset stuff
Application.StatusBar = sb
Application.DisplayStatusBar = dsb
Application.Calculation = calc
Application.ScreenUpdating = su
Beep
MsgBox "Complete!", vbInformation
End Sub