根据单元格值移动范围

Question

我对 VBA 很陌生，并且正在研究仅当同一行中的单元格值是“已完成”时才复制范围的代码。

然后将复制的范围粘贴到另一列中，并删除原始范围。

如果它也可以循环，那就太好了，这样当单元格值更改为完成时，移动会自动发生。到目前为止我的代码是：

Sub Move()

    Dim r As Range, cell As Range, mynumber As Long

    Set r = Range("O1:O1000")

    mynumber = 1
    For Each cell In r
        If cell.Value = "Completed" Then
        Range("Q15:AE15").Select
        Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

        If cell.Value = "Completed" Then
        ActiveCell.Select
        ActiveCell.Range("B:O").Select
        Selection.Copy
        Range("Q14").Select
        ActiveSheet.Paste

        End If

        Next

    End Sub

Answer 1

您需要使用内置事件Worksheet_Change：

在vbe 的左侧，双击您希望此代码起作用的工作表。您将访问工作表模块，在文本编辑器上有 2 个列表来选择您要使用的事件。

您可以在那里使用此代码，它将“已完成”行的数据从 B:O 传输到 Q:AE：

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub

If Not Application.Intersect(Me.Columns(15), Target) Is Nothing Then
    If Target.Value <> "Completed" Then
    Else
        Dim FirstFreeRowInColQ As Long
        FirstFreeRowInColQ = Me.Range("Q" & Me.Rows.Count).End(xlUp).Row + 1

        Me.Range("Q" & FirstFreeRowInColQ & ":AE" & FirstFreeRowInColQ).Value = _
            Me.Range("B" & Target.Row & ":O" & Target.Row).Value
    End If
Else
End If

End Sub

Answer 2

我使用偏移量来移动数据，并使用插入“删除”功能来删除原始范围。偏移量创建了一个无边框单元格，我必须对其进行修复，并且在将“已完成”单元格移动到新范围后，我还清除了它。

我仍在为循环而苦苦挣扎，但我会继续尝试。

Sub Move()

Dim r As Range, cell As Range, mynumber As Long

Set r = Range("O1:O1000")

mynumber = 1
For Each cell In r
    If cell.Value = "Completed" Then
    Range("Q14:AE14").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    End If

    If cell.Value = "Completed" Then
    cell.Select
    cell.Value = "Delete"
    Range(ActiveCell, ActiveCell.Offset(0, -14)).Select
    Selection.Copy
    Range("Q14").Select
    ActiveSheet.Paste

       With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With

    Range("AE14").ClearContents

    End If

    If cell.Value = "Delete" Then
    cell.Select
    Range(ActiveCell, ActiveCell.Offset(0, -14)).Select
    Selection.Delete Shift:=xlUp

    End If

    Next

End Sub