需要遍历 AI 列，如果单元格不为空，则查看 W 列并在下一列中移动数字

Question

这是一个新的图像，希望充分地显示必须移动的内容和位置'这是我一直在尝试的一些代码的示例。

sub
For Each cel In Range("W2:W1000")
    If cel.Value = "Credit Adj W/O To Collection" AND
    Range("AI2:AI1000").Cells.Value > ""  THEN
    cel.Offset(0,-9).value =
end sub

基本上我需要在 W 列中查找特定文本，如果找到将数字移到下一列，将 X 列移到与 AI 列中的数据在同一行的 Y 列，但在 Y 列中。我的问题是它必须向上移动的行数根据数据在 AI 列中的位置而有所不同。 看截图

Answer 1

尝试这个：

Sub tester()
    
    Dim c As Range, ws As Worksheet, rw As Range
    Set ws = ActiveSheet 'always use an explicit sheet reference
    
    For Each c In ws.Range("W2:W1000").Cells
        Set rw = c.EntireRow  'the whole row for the cell
        If c.Value = "Credit Adj W/O To Collection" And _
                      IsNumeric(rw.Columns("X").Value) Then
            'copy the value to Col Y in the row above which has a value in Col AI
            ws.Cells(rw.Columns("AI").End(xlUp).Row, "Y").Value = rw.Columns("X").Value
            rw.Columns("X").ClearContents ' clear the "X" value
        
        End If
    Next c
End Sub

Answer 2

一个棘手的专栏更新

1. 循环（ r = r + 1 ）从第一行到最后一行（后者在W列中计算）。
2. 当AI列不为空时，将行号写入变量 ( rFound )。
3. 继续循环（ r = r + 1 ）。 当W列等于字符串Credit Adj W/O To Collection时，将当前行的X列中的值写入变量 ( rFound ) 中保存的行的Y列。
4. 通过在步骤 2. 和 3. 之间交替，继续循环 ( r = r + 1 ) 直到最后一行。

Option Explicit

Sub UpdateInsAmt()
    
    Const wsName As String = "Sheet1"
    Const rStart As Long = 4
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    Dim rLast As Long: rLast = ws.Cells(ws.Rows.Count, "W").End(xlUp).Row
    Dim r As Long: r = rStart
    Dim rFound As Long
    
    Do
        If Len(CStr(ws.Cells(r, "AI").Value)) > 0 Then ' is not blank
            rFound = r
            r = r + 1 ' it can't be in the same row
            Do
                If StrComp(CStr(ws.Cells(r, "W").Value), _
                        "Credit Adj W/O To Collection", vbTextCompare) = 0 Then
                    ws.Cells(rFound, "Y").Value = ws.Cells(r, "X").Value
                    Exit Do ' value found and written so stop looping ...***
                'Else ' value not found ...
                End If
                r = r + 1 ' ... so incremenet row
            Loop Until r > rLast
        ' Else ' is blank ...
        End If
        r = r + 1 ' ... so increment row, ...*** and increment row
    Loop Until r > rLast
    
End Sub