基于特定单元格条件，将单元格从一列移动到另一列的VBA代码

Question

我看到了一些关于使用VBA将单元格从一个工作簿移动到另一个工作簿或从一个工作表移动到另一个工作表的问题，但是我希望根据特定条件将信息从同一工作表中的一列移动到另一列。

我编写了以下代码，将包含单词“save”的单元格从A列移动到同一工作表中的I列：

Sub Findandcut()
    Dim rngA As Range
    Dim cell As Range

    Set rngA = Sheets("Jan BY").Range("A2:A1000")
    For Each cell In rngA
        If cell.Value = "save" Then
            cell.EntireRow.Cut
            Sheets("Jan BY").Range("I2").End(xlDown).Select
            ActiveSheet.Paste
        End If
    Next cell

End Sub

然而，尽管我运行这个宏时没有显示任何错误，但它似乎也没有做任何其他事情。没有选择、剪切或粘贴任何内容。在代码中我哪里出错了？

- Anika Leena

---

非常抱歉我没有给出更具体的说明，因为所有这些答案都很好，并且完全符合我在问题中所要求的。当我将列A的单元格内容移动到列I时，我还需要将整行一起移动。例如，如果A1单元格中有单词"save"，B1单元格中有数字8，那么A1和B1都需要向右移动，以便"save"现在位于I1，8现在位于J1。希望这样说得清楚吗？这就是为什么我包含了"cell.EntireRow.cut"代码行的原因。 - Anika Leena

Answer 1

将包含“save”单词的A列单元格移动到同一工作表中的I列。您的代码与此无关。要实现您的需求，您需要像这样做：

Sub Findandcut()
    Dim row As Long

    For row = 2 To 1000
        ' Check if "save" appears in the value anywhere.
        If Range("A" & row).Value Like "*save*" Then
            ' Copy the value and then blank the source.
            Range("I" & row).Value = Range("A" & row).Value
            Range("A" & row).Value = ""
        End If
    Next

End Sub

---

编辑

如果您想将整个行的内容移动到以列I开始，请替换相关代码部分：

If Range("A" & row).Value Like "*save*" Then
    ' Shift the row so it starts at column I.
    Dim i As Integer
    For i = 1 To 8
        Range("A" & row).Insert Shift:=xlToRight
    Next
End If

- Jason Faulkner

---

Jason，你的代码完美无缺，它确实像我想要的那样移动了列。我完全忘记了添加一个条件：如果A列中的值包含“save”，则需要将整行移动到I列。因此，我不需要清空源数据，而是需要剪切这些行并将它们移动7列。如果我可以修改你的代码以包括这个更改，那就太完美了。很抱歉没有更具体地说明！ - Anika Leena

@AnikaLeena - 我不确定你的意思是“如果列A中包含“save”，我需要将整行移动到列I。”你是说如果A包含“save”，你想要将整行的内容向右移动7个单元格吗？ - Jason Faulkner

是的，所以如果例如A1包含“保存”，B1包含一个数字，“保存”将被移动到I1，而B1中的数字将被移动到J1。 - Anika Leena

谢谢，这很完美！ - Anika Leena

@ Jason 如果我想要在所有列中搜索值，而不仅仅是搜索A列，你会如何将其实现到这个子程序中？ - Michael

Answer 2

也许是这样的：

Sub Findandcut()
    Dim rngA As Range
    Dim cell As Range

    Set rngA = Sheets("Jan BY").Range("A2:A1000")
    For Each cell In rngA
        If cell.Value = "save" Then
            cell.Copy cell.Offset(0, 8)
            cell.Clear
        End If
    Next cell

End Sub

这段代码向下扫描列，检测匹配项并进行复制。复制会带来格式和值。

- Gary's Student

Answer 3

Sub Findandcut()
    Dim rngA As Range
    Dim cell As Range

    Set rngA = Sheets("Jan BY").Range("A2:A1000")
    For Each cell In rngA
        If cell.Value = "save" Then
            Sheets("Jan BY").Range("I" & Rows.Count).End(xlUp).Select
            Selection.Value = cell.Value
            cell.Delete Shift:=xlUp
        End If
    Next cell

End Sub

- RAJA THEVAR