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

 

[OilEconomist]

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

Can the data be sorted by column D ?

Yes because I have a column A which will allow me resort to how it original was. So I could sort by column D and then just past the visible cells over in the same section in E and just re-sort, but I wanted something a bit more dynamic. Column E has about 100,000 rows of data that starts in row 9 with a header in row 8.

 

[OilEconomist]

@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

Thanks @johnnyL for your quick response and code. This did not work in total, but it sorted the data through the 15,062 row (Row 15,070). After that it was #N/A.

I do have a column where I can resort the data in the case it becomes unsorted. So the columns are from A to H with rows 8 to 91,552 (last will vary). Please note that column 8 is a header row.

 

[OilEconomist]

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

Thanks @footoo for your quick response and code. I believe this worked but may need some modifications. I think I need to adjust since you start with 8 and that's the header row and also, and you sort the data in alphabetic order based on column D. I need to keep it in it's original order.

So the columns are from A to H with rows 8 to 91,552 (last row will vary). Please note that column 8 is a header row.

Can you modify this to ensure nothing is being done to the header row. Also, can you change it to where the order is based on column A which will ensure that column D and E keep their order. Remember the data starts in row 9 and there is header in row 8. I tried to modify it but I don't think I did it correctly.

 

[johnnyL]

Thanks @johnnyL for your quick response and code. This did not work in total, but it sorted the data through the 15,062 row (Row 15,070). After that it was #N/A.

I do have a column where I can resort the data in the case it becomes unsorted. So the columns are from A to H with rows 8 to 91,552 (last will vary). Please note that column 8 is a header row.

Thank you for the response @OilEconomist. I am trying to track that issue down.

Did you try post #9?

 

[OilEconomist]

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

@johnnyL Thanks for this code as it seems similar to what @footoo did in post 7. Apologies to both of you for not giving the dimensions before hand.

Same issue is that it does not sort the data back to it's original form.

So the columns are from A to H with rows 8 to 91,552 (last row will vary). Please note that column 8 is a header row. This entire thing needs to get back to its original order where column A is numbered so that can be used.

Can you modify this to ensure nothing is being done to the header row. Also, can you change it to where the order is based on column A which will ensure that column D and E keep their order. Remember the data starts in row 9 and there is header in row 8. I tried to modify it but I don't think I did it correctly.

 

[johnnyL]

So are you saying that the original code that you posted is not correct? because the code in post #9 yields the same result as your original code, on my end anyways.

 

[OilEconomist]

So are you saying that the original code that you posted is not correct? because the code in post #9 yields the same result as your original code, on my end anyways.

No. That code is correct. I am just saying there is a header row in row 8 and the entire thing is from column A through G and then it becomes A through H because column C is pasted into column H. If you look at when it does the loop it starts in row 9, not 8.

Also, post 9 does not put it back in it's original order.

I was just asking for adjustments to make sure (1) nothing is happening to row 8 and (2) it's sorted back to it's original order. Column A is numbered so it can be based on that column.

 

[johnnyL]

The term sort is what confuses me.

Leaving Row 8 as it is, no problem, easy fix.

Can you post an example of a few rows of what the initial and final results could be?

 

[OilEconomist]

The term sort is what confuses me.

Leaving Row 8 as it is, no problem, easy fix.

Can you post an example of a few rows of what the initial and final results could be?

Sort as in order like under excel if you look under "Data" and then you "Sort" it. I have the data in a certain order and I don't want it changed. Post 9 puts into alphabetic order based on column D and I don't want that.

If you fix leaving row 8 that and sort based on column A at the end, everything should be fine. Remember column once Column C is pasted into Column H it becomes column A through H. So what included in the sorting depends on when you sort. Before C is moved to H or after.

I have it like this, but with about 100k rows versus 10. Please keep in mind this is dummy data, but you can use the same concept on it.

This is what I want I highlighted the changes, but I don't need that done on your end (highlight the changes). It's just for illustration purposes.

This is what post 9 comes up with:

 

[footoo]

Sub Test()
Dim col&, LastRow&, rng As Range
'Locate blank column to use as helper column
col = Range([A1], ActiveSheet.UsedRange).Columns.Count + 2
LastRow = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
Set rng = Range("D9:D" & LastRow)
'Enter sequential numbers in helper column starting at row 9
rng.Offset(0, col - rng.Column) = Evaluate("ROW(1:" & LastRow & ")")
'Sort by column D to put blank cells at bottom
rng.EntireRow.Sort Key1:=[D9], Order1:=xlAscending, Header:=xlNo
Range("C9:C" & LastRow).Cut Range("H9")
On Error Resume Next
'Copy non-blank cells from column D to E
rng.SpecialCells(xlCellTypeConstants).Copy [E9]
On Error GoTo 0
'Sort data into original sequence
rng.EntireRow.Sort Key1:=Cells(9, col), Order1:=xlAscending, Header:=xlNo
'Delete helper column
Columns(col).Delete
End Sub