CodePudding user response：

Try this:

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

CodePudding user response：

A Tricky Column Update

1. Loop (r = r 1) from the first row to the last row (the latter calculated in column W).
2. When column AI is not blank, write the row number to a variable (rFound).
3. Continue looping (r = r 1). When column W is equal to the string Credit Adj W/O To Collection, write the value in column X of the current row to column Y of the row kept in the variable (rFound).
4. Continue looping (r = r 1) by alternating between steps 2. and 3. until the last row.

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