使用 Excel 宏/VBA 將數據剪切並粘貼到新創建的行中

Question

我希望能夠修改我正在為我的公司運行的當前報告。 該報告帶回了有關事件的一些基本信息。 在數據的末尾，最后一列列出了事件描述。 我想在包含“總計”的任何行上方插入一個新行，然后插入損失描述：描述。

我遇到的問題是我無法在新創建的行中將“描述”剪切並粘貼到 Loss Description: 后面。 我無法發布報告的圖像，但我使用的代碼將在下面。 當我運行宏時，會在包含“總計”的行上方創建一個新行，但帶有描述的列不會剪切和粘貼。 描述在 Excel 電子表格的 Q 列中，損失描述：正在 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

您的工作表上發生了一些奇怪的事情，其中End(xlUp)沒有表現出應有的行為 - 由於某種原因，它停在空單元格上......

測試了這種替代方法，它適用於您的示例工作表：

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