需要循环通过列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列中的位置而不同。见截图

​

​

你们所有的人都帮了大忙，但它仍然没有移动任何数字。我又加了一张截图。我需要查找蓝色的文本，如果发现，请将X列中的金额向右移动，并移动到在AI列中有值的行。每个条目之间的差距可能不同，如屏幕截图所示。可能是2或4或5，只是取决于列AI。而且，第一个条目可能并不总是在与这里相同的行中开始。在整个电子表格中，W栏和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. 继续循环(r = r + 1)，在步骤2和步骤3之间交替，直到最后一行。

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