使用 Excel 宏/VBA 将数据剪切并粘贴到新创建的行中

Question

I want to be able to modify a current report which I am running for my company. The report brings back some basic information on an Event. At the end of the data, there is one final column which lists the Event Description. I want to insert a new row above any row which contains "Totals" and then insert Loss Description: Description.

The issue I am running into is that I can't get the "Descriptions" to cut and paste behind Loss Description: in the newly created row. I can't post an image of the report but the code I'm using will be below. When I run the Macro, a new row gets created above the Row which contains "Totals" but the column with the description does not cut and paste. The description is in Column Q of the Excel Spreadsheet and the Loss Description: is being created in Column A.

   Sub InsertAdj()
    Dim LR As Long, i As Integer, n As Integer
    LR = Cells(Rows.Count, "A").End(xlUp).Row
    For i = LR To 2 Step -1
    If Left(Range("A" & i), 6) = "Totals" Then
    Rows(i).Insert Shift:=xlDown
    n = WorksheetFunction.Match(WorksheetFunction.Lookup("zzzzz", Range("A1:A" & i)), Range("A1:A" & i), 
    0)
    Cells(i, 1) = "Loss Description: " & Cells(n + 1, 16).Value
    Cells(n + 1, 16).ClearContents
    End If
    Next i
    End Sub

Answer 1

There's something odd going on on your worksheet where End(xlUp) doesn't behave as it should - for some reason it stops on empty cells...

Tested this alternate approach and it works for me on your sample worksheet:

Sub InsertAdj()
    Dim LR As Long, i As Integer, n As Integer, descCell As Range
    Dim sht As Worksheet

    Set sht = ActiveSheet
    LR = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

    For i = LR To 2 Step -1
        If Left(sht.Range("A" & i), 6) = "Totals" Then
            sht.Rows(i).Insert Shift:=xlDown

            'end(xlUp) does not work for some reason, so call a function to find the description
            Set descCell = FindDescriptionCell(sht.Cells(i + 1, "Q")) 'call function

            sht.Cells(i, 1) = "Loss Description: " & descCell.Value
            descCell.ClearContents
        End If
    Next i
End Sub

Function FindDescriptionCell(c As Range)
    Dim f
    'search up for a value
    Set f = c.EntireColumn.Find(what:="*", after:=c, _
             searchorder:=xlByColumns, searchdirection:=xlPrevious)
    If Not f Is Nothing Then
        'ensure Find didn't loop back below the start cell
        If f.Row < c.Row Then Set FindDescriptionCell = f
    End If
End Function