基于单元值的移动范围

我对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 ：

在左边，双击你想要这个代码工作的工作表。 您将访问工作表模块，在文本编辑器中有两个列表，用于select要使用的事件。

你可以在这里使用这个代码，它会把'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

我用偏移来移动数据和插入“删除”function删除原来的范围。 偏移量创build了一个无边界的单元格，我必须修复，并且一旦移动到新的范围，我也清除了“完成”单元格。

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

 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