VBA code for moving cells from one column to another based on specific cell criteria

问题

I've seen several questions asking about moving cells from one workbook to another or one sheet to another using VBA, but I'm hoping to move information from one column to another in the same sheet based on specific criteria.

I wrote this code to move cells from column A if they contained the word "save" to column I in the same sheet:

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

But, while this macro doesn't display any errors when I run it, it also doesn't seem to do much of anything else, either. Nothing is selected, cut, or pasted. Where in the code did I go wrong?

回答1:

move cells from column A if they contained the word "save" to column I in the same sheet

Your code doesn't do anything like this.

To accomplish what your requirements are, you would need something like this:

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

---

Edit

If you want to shift the entire contents of row over so it starts at column I, just replace the relevant section of code:

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

回答2:

Perhaps something like:

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

This code scans down the column, detects the matches and performs the copy. Copying brings over the format as well as the value.

回答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

来源：https://stackoverflow.com/questions/28349198/vba-code-for-moving-cells-from-one-column-to-another-based-on-specific-cell-crit