Cut and Paste Insert Cells if It Contains a Value

[OilEconomist]

Hello and thanks in advance to all those who attempt to assist and I will post a response on feedback to proposed solutions.

I have a large data set which consists of more than 200,000 rows. I am searching column R to see if has total in it. If it does, I select it and all the cells within that row to the right of it up until the last cell (last column). I then cut it, and past it in the row below it starting in column A. Since there is data already in Columns A through Q all the way up to the last row of the spreadsheet, I have to insert the cut data. When I run the following code, nothing happens. Any insight on why?

Sub Total()


    'Activate the sheet
        Worksheets("Data.Raw").Activate




    'Find the last row.
        Dim LastRow As Long
              
        LastRow = Cells.Find(What:="*", _
        after:=Range("A1"), _
        LookAt:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Row
        
    'Find the last column.
        Dim LastColumn As Long
        
        LastColumn = Cells.Find(What:="*", _
        after:=Range("A1"), _
        LookAt:=xlPart, _
        LookIn:=xlFormulas, _
        SearchOrder:=xlByColumns, _
        SearchDirection:=xlPrevious, _
        MatchCase:=False).Column
        




    'Move Total Line within the Data Set
        
        Dim i As Long
        
        For i = LastRow To 1 Step -1
        
           If LCase(Cells(i, 18).Value) = "Total" Then
        
           Range("R" & i, LastColumn).Cut
             
           Range("A" & i + 1).Insert xlShiftDown
                      
           
        End If
        
        Next i
        


End Sub

Once again thanks!

 

[Fluff]

Try

Range("R" & i, Cells(i, Lastcolumn)).Cut

You also need to change this

If LCase(Cells(i, 18).Value) = "[COLOR=#ff0000]t[/COLOR]otal" Then

 

[Fluff]

For 200,000 rows this should be quicker

Sub Total()
   Dim Lc As Long
   Dim Ar As Areas
   Dim i As Long

   Worksheets("Data.Raw").Activate
   
   Lc = Cells.Find(What:="*", _
      after:=Range("A1"), _
      LookAt:=xlPart, _
      lookIn:=xlFormulas, _
      SearchOrder:=xlByColumns, _
      SearchDirection:=xlPrevious, _
      MatchCase:=False).Column
   With Range("R1", Range("R" & Rows.Count).End(xlUp))
      .Replace "total", "=XXXTotal", , , False, , False, False
      Set Ar = .SpecialCells(xlFormulas, xlErrors).Areas
      .Replace "=XXXTotal", "Total", , , False, , False, False
   End With
   For i = Ar.Count To 1 Step -1
      Ar(i).Offset(1).EntireRow.Insert xlDown
      Range(Ar(i), Cells(Ar(i).Row, Lc)).Cut Cells(Ar(i).Row + 1, 1)
   Next i
End Sub

 

[OilEconomist]

Thanks Fluff! I used the corrections that you posted in Post #2 and that worked. When I get a chance I will try to test the alternative faster method in Post #3 as I would like to make my spreadsheet as efficient as possible.

 

[Fluff]

You're welcome & thanks for the feedback.