VBA Code Simplify the Check, Copy, Paste Loop

[OilEconomist]

Thanks in advance for any assistance. Is there a simpler faster way to perform the following task? I am finding the last row in a sheet which contains around 100k rows, then comparing the cells in each of two rows and performing a function. This code takes about 42 second to run.

Option Explicit
'***************************************************************************************************************
Public Sub Test()

'_______________________________________________________________________________________________________________
'Turn off alerts, screen updates, and automatic calculation
        'Turn off Display Alerts
            Application.DisplayAlerts = False

        'Turn off Screen Update
            Application.ScreenUpdating = False

        'Turn off Automatic Calculations
            Application.Calculation = xlManual
            


'_______________________________________________________________________________________________________________
'Dimensioning


    Dim j As Long
    Dim LastRow As Long

    Dim StartTime As Double
    Dim SecondsElapsed As Double

'_______________________________________________________________________________________________________________

 StartTime = Timer 'Remember time when macro starts

                    
Sheets("Sheet1").Activate
    
LastRow = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
   
'Moving and adjusting columns
            'Column C move
              Range("C8:C" & LastRow).Cut Range("H8")
                
            'Column D copy and paste values and then move
                For j = 9 To LastRow
                    If Range("D" & j) <> "" Then Range("D" & j).Copy Range("E" & j)
                Next j

    
                Range("D8:D" & LastRow).Clear
                

'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation


'_________________________________________________________________________________________________________________
'Turn on alerts, screen updates, and calculate
        'Turn On Display Alerts
            'Application.DisplayAlerts = True

        'Turn on Screen Update
            'Application.ScreenUpdating = True

        'Turn off Automatic Calculations
            'Calculate

'_________________________________________________________________________________________________________________
'Place the curser in cell



End Sub

 

[footoo]

Why do you need the loop?
Why not just this :

Range("D9:D" & LastRow).Copy Range("E9")

 

[DanteAmor]

Do you have formulas in the cells?
Before running the macro, do you have values in column E?

 

[OilEconomist]

Do you have formulas in the cells?
Before running the macro, do you have values in column E?

Thanks @footoo for your response. I cannot use

Range("D9:D" & LastRow).Copy Range("E9")

because I have values in column E. I only want to replace the value in E if D has something in it. At times D will be blank, which means keep the original value from E.

@DanteAmor Thanks for your response. There are no formulas in the cells

 

[footoo]

Can the data be sorted by column D ?

 

[johnnyL]

@OilEconomist How about this:

Sub MyTest()
'_______________________________________________________________________________________________________________
'Turn off alerts, screen updates, and automatic calculation
'
    Application.EnableEvents = False                                        ' Turn off EnableEvents
    Application.DisplayAlerts = False                                       ' Turn off Display Alerts
    Application.ScreenUpdating = False                                      ' Turn off Screen Update
    Application.Calculation = xlManual                                      ' Turn off Automatic Calculations
'_______________________________________________________________________________________________________________
'Dimensioning
'
    Dim j               As Long
    Dim LastRow         As Long
    Dim StartTime       As Double
    Dim SecondsElapsed  As Double
    Dim TestArrayD      As Variant
    Dim TestArrayE      As Variant
    Dim ArrayListE      As Object
'_______________________________________________________________________________________________________________
'
    Set ArrayListE = CreateObject("System.Collections.ArrayList")
'
    StartTime = Timer 'Remember time when macro starts
'
    Sheets("Sheet1").Activate
'
    LastRow = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
'
'   Moving and adjusting columns
'   Column C move to column H
    Range("C8:C" & LastRow).Cut Range("H8")
'
    TestArrayD = Range("D1:D" & LastRow)
'
    For j = 9 To LastRow
        If TestArrayD(j, 1) <> "" Then ArrayListE.Add TestArrayD(j, 1)
    Next j
'
    Range("E9:E" & LastRow) = WorksheetFunction.Transpose(ArrayListE.ToArray)
'
    Range("D8:D" & LastRow).Clear
'
'   Determine how many seconds code took to run
    SecondsElapsed = Round(Timer - StartTime, 2)
'
'   Notify user in seconds
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
'_________________________________________________________________________________________________________________
'
'   Turn on alerts, screen updates, and calculate           ' Why is this section not enabled?
'
    Application.Calculation = xlCalculationAutomatic                        ' Turn on AutoCalculation
    Application.ScreenUpdating = True                                       ' Turn on Screen Update
    Application.DisplayAlerts = True                                        ' Turn On Display Alerts
    Application.EnableEvents = True                                         ' Turn on EnableEvents
'_________________________________________________________________________________________________________________
'
End Sub

 

[footoo]

Maybe this :

Sub Test()
Dim col&, LastRow&, rng As Range
col = Range([A1], ActiveSheet.UsedRange).Columns.Count + 1
LastRow =Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
Set rng = Range("D8:D" & LastRow)
rng.Offset(0, col - rng.Column) = Evaluate("ROW(1:" & LastRow & ")")
rng.EntireRow.Sort Key1:=[D8], Order1:=xlAscending, Header:=xlNo
Range("C8:C" & LastRow).Cut Range("H8")
On Error Resume Next
rng.SpecialCells(xlCellTypeConstants).Copy [E8]
On Error GoTo 0
rng.EntireRow.Sort Key1:=Cells(8, col), Order1:=xlAscending, Header:=xlNo
Columns(col).Delete
End Sub

 

[johnnyL]

@footoo I think you mean something like this:

Sub Test()
'
    Dim col&, LastRow&, rng As Range
'
    col = Range([A1], ActiveSheet.UsedRange).Columns.Count + 1
    LastRow = Cells(Rows.Count, "A").End(3).Row
'
    Set rng = Range("D8:D" & LastRow)
'
    rng.Offset(0, col - rng.Column) = Evaluate("ROW(1:" & LastRow & ")")
    rng.EntireRow.Sort Key1:=[D8], Order1:=xlAscending, Header:=xlNo
'
    Range("C8:C" & LastRow).Cut Range("H8")
'
    On Error Resume Next
    rng.SpecialCells(xlCellTypeConstants).Copy [E8]
    On Error GoTo 0
'
    rng.EntireRow.Sort Key1:=Cells(8, col), Order1:=xlAscending, Header:=xlNo
'
    Range("D8:D" & LastRow).Clear
End Sub

 

[johnnyL]

Or more like the OP ...

Sub Test()
'
    Dim StartTime As Double
    Dim SecondsElapsed As Double
    Dim col&, LastRow&, rng As Range
'_______________________________________________________________________________________________________________

    StartTime = Timer 'Remember time when macro starts
'
    col = Range([A1], ActiveSheet.UsedRange).Columns.Count + 1
    LastRow = Cells(Rows.Count, "A").End(3).Row
'
    Set rng = Range("D8:D" & LastRow)
'
    rng.Offset(0, col - rng.Column) = Evaluate("ROW(1:" & LastRow & ")")
    rng.EntireRow.Sort Key1:=[D8], Order1:=xlAscending, Header:=xlNo
'
    Range("C8:C" & LastRow).Cut Range("H8")
'
    On Error Resume Next
    rng.SpecialCells(xlCellTypeConstants).Copy [E8]
    On Error GoTo 0
'
    rng.EntireRow.Sort Key1:=Cells(8, col), Order1:=xlAscending, Header:=xlNo
'
    Range("D8:D" & LastRow).Clear
'
'   Determine how many seconds code took to run
    SecondsElapsed = Round(Timer - StartTime, 2)
'
'   Notify user in seconds
    MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub

 

[footoo]

@footoo I think you mean something like this:

Sub Test()
'
    Dim col&, LastRow&, rng As Range
'
    col = Range([A1], ActiveSheet.UsedRange).Columns.Count + 1
    LastRow = Cells(Rows.Count, "A").End(3).Row
'
    Set rng = Range("D8:D" & LastRow)
'
    rng.Offset(0, col - rng.Column) = Evaluate("ROW(1:" & LastRow & ")")
    rng.EntireRow.Sort Key1:=[D8], Order1:=xlAscending, Header:=xlNo
'
    Range("C8:C" & LastRow).Cut Range("H8")
'
    On Error Resume Next
    rng.SpecialCells(xlCellTypeConstants).Copy [E8]
    On Error GoTo 0
'
    rng.EntireRow.Sort Key1:=Cells(8, col), Order1:=xlAscending, Header:=xlNo
'
    Range("D8:D" & LastRow).Clear
End Sub

Your code is the same as I posted. Does exactly same.

Except for :

LastRow = Cells(Rows.Count, "A").End(3).Row

This might not return the row the OP wants.