根據單元格值移動范圍

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個列表，用於選擇要使用的事件。

你可以在那里使用這個代碼，它會將'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