循环直到最后一行并在行更改时更新单元格值

Question

嗨，我正在尝试更新所有行的单元格值，直到行号发生变化。这是我的代码：

 Sub MyLoop()

 Dim i As Integer
 Dim var As String
 Dim LastRow As Long

 LastRow = Range("A" & Rows.Count).End(xlUp).Row

 i = 1

 var = Cells(i, 4).Value

 For i = 1 To LastRow

    If Range("A" & i).Value = "1" Then

       Cells(i, 2).Value = var
  
    End If

    var = Cells(i, 4).Value

 Next i

 End Sub

我附上了运行例程后的前后图像。基本上循环遍历所有行，在 A 列中是数字更改将 D 列中的值存储并将其粘贴到 B 列中，直到行号发生更改。

之前：

之后：

亲切的问候

Answer 1

真的是数字变了还是D列的词变了？

Columns("D:D").Cut Destination:=Columns("B:B")
Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value = Range("B1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Value

Answer 2

Sub MyLoop()

 Dim i As Integer
 Dim var As String
 Dim LastRow As Long

 LastRow = Range("A" & Rows.Count).End(xlUp).Row

 For i = 1 To LastRow
    IF Cells(i, 4).Value<>"" Then 'Get new value from column 4
       var = Cells(i, 4).Value
    End If

    Cells(i, 2).Value = var       'Assign value to column 2

 Next i

 End Sub

Answer 3

填列

快速修复

Sub MyLoop()

    Dim LastRow As Long
    Dim i As Long
    Dim A As Variant
    Dim D As Variant
    
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 1 To LastRow
        If Cells(i, 1).Value <> A Then
            A = Cells(i, 1).Value
            D = Cells(i, 4).Value
        End If
        Cells(i, 2).Value = D
    Next i

End Sub

更灵活的解决方案

• 调整常量部分中的值。

---

Option Explicit

Sub fillColumn()
    
    ' Define constants.
    Const wsName As String = "Sheet1"
    Const ColumnsAddress As String = "A:D"
    Const LookupCol As Long = 1
    Const CriteriaCol As Long = 4
    Const ResultCol As Long = 2
    Const FirstRow As Long = 2
    
    ' Define Source Range.
    Dim rng As Range
    With ThisWorkbook.Worksheets(wsName).Columns(ColumnsAddress)
        Set rng = .Columns(LookupCol).Resize(.Rows.Count - FirstRow + 1) _
            .Offset(FirstRow - 1).Find( _
                What:="*", _
                LookIn:=xlFormulas, _
                SearchDirection:=xlPrevious)
        If rng Is Nothing Then
            Exit Sub
        End If
        Set rng = .Resize(rng.Row - FirstRow + 1).Offset(FirstRow - 1)
    End With
    
    ' Write values from Source Range to Data Array.
    Dim Data As Variant: Data = rng.Value
    
    ' Define Result Array.
    Dim Result As Variant: ReDim Result(1 To UBound(Data, 1), 1 To 1)
    
    ' Declare additional variables.
    Dim cLookup As Variant ' Current Lookup Value
    Dim cCriteria As Variant ' Current Criteria Value
    Dim i As Long ' Rows Counter
    
    ' Write values from Data Array to Result Array.
    For i = 1 To UBound(Data, 1)
        If Data(i, LookupCol) <> cLookup Then
            cLookup = Data(i, LookupCol)
            cCriteria = Data(i, CriteriaCol)
        End If
        Result(i, 1) = cCriteria
    Next i
    
    ' Write from Result Array to Destination Column Range.
    rng.Columns(ResultCol).Value = Result

End Sub