Question

我对VBA很陌生，只是在同一行中的单元格值为＃34;已完成＆＃34;时，我正在处理代码以复制范围。

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

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

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个列表，用于选择要使用的事件。

你可以在那里使用这个代码，它会将'Completed'行的数据从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

我使用offset来移动数据并插入“Delete”函数来删除原始范围。偏移创建了一个无边界的单元格，我必须修复它，并且一旦移动到新范围，我也清除了“已完成”单元格。

我仍在努力学习循环，但我会继续尝试。

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

根据单元格值移动范围

2 个答案: