找到第一个“To Date”，选择“To Date”下的单元格，粘贴前面单元格中的值，然后转到下一个To Date

Question

I need your help in order to fix this code. Objective of this code is set a range. find the first "To Date", then select all the cells under "To Date" paste the value in the previous cells (for example the first "To Date" is in cell F4 contains value from F5:F"N"(N=last row) then paste F5:F"N" values in E5:E"N", then go to the next To Date.

The problem I am facing in this code is that

1. the Code does not select the last row in under the "To Date" (except for the first time)

2. the code runs in infinite loop does not stop after the last "To Date"

   Sub FindAddressColumn() Dim twb As ThisWorkbook Dim ws As Worksheet Dim lastRow As Long Dim LastCol As Long Dim lr As Long Dim getLastCell As Range Dim firstAddress As String Dim rngAddress As Range Const strFindMe As String = "To Date" Set twb = ThisWorkbook For Each ws In twb.Worksheets If ws.Name = "QCR Summary" Then lastRow = ws.Cells.Find("*", ws.Cells(1, 1), xlFormulas, xlPart, xlByRows, _ xlPrevious).Row LastCol = ws.Cells.Find("*", ws.Cells(1, 1), xlFormulas, xlPart, xlByColumns, _ xlPrevious).Column Set getLastCell = ws.Cells(lastRow, LastCol) With ws.Range("A1", getLastCell) Set rngAddress = .Find(What:=strFindMe, LookIn:=xlValues) If rngAddress Is Nothing Then Exit Sub End If firstAddress = rngAddress.Address Do Set rngAddress = .FindNext(rngAddress) Range(rngAddress, rngAddress.End(xlDown)).Select 'MsgBox rngAddress.Address Loop While Not rngAddress Is Nothing And rngAddress <> firstAddress End With End If Next ws End Sub

Answer 1

Because you named your variable rngAddress the names suggests that the variable contains an address string while it actually contains a Range object.

Then you compare rngAddress <> firstAddress but if you have a look at your variable declarations

Dim firstAddress As String
Dim rngAddress As Range

You see that you compare a Range object with a String which cannot work properly. Because rngAddress is a range object it defaults to rngAddress.Value so you actually compare the value of the cell rngAddress with an address string firstAddress .

Replace

Loop While Not rngAddress Is Nothing And rngAddress <> firstAddress

with

Loop While rngAddress.Address <> firstAddress

Note that you can omit the part Not rngAddress Is Nothing here in the loop because that can never happen. If it would be Nothing then it would have already Exit Sub in the step earlier where you checked If rngAddress Is Nothing Then .

Also Dim twb As ThisWorkbook this should error because it must be Dim twb As Workbook .

Finally your loop is a bit unnecessary, because you can access your sheet named QCR Summary directly without looping throug all worksheets. Which would be much quicker:

Option Explicit

Public Sub FindAddressColumn()
    Const strFindMe As String = "To Date"
    
    Dim twb As Workbook
    Set twb = ThisWorkbook
    
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = twb.Worksheets("QCR Summary")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "Worksheet 'QCR Summary' does not exist."
        Exit Sub
    End If
    
    Dim lastRow As Long
    lastRow = ws.Cells.Find("*", ws.Cells(1, 1), xlFormulas, xlPart, xlByRows, _
                                     xlPrevious).Row
    Dim LastCol As Long
    LastCol = ws.Cells.Find("*", ws.Cells(1, 1), xlFormulas, xlPart, xlByColumns, _
                                     xlPrevious).Column
    
    Dim getLastCell As Range
    Set getLastCell = ws.Cells(lastRow, LastCol)
    
    With ws.Range("A1", getLastCell)
        Dim rngAddress As Range
        Set rngAddress = .Find(What:=strFindMe, LookIn:=xlValues)
    
        If rngAddress Is Nothing Then
            Exit Sub
        End If
        
        Dim firstAddress As String
        firstAddress = rngAddress.Address
    
        Do
            Set rngAddress = .FindNext(rngAddress)
            Range(rngAddress, rngAddress.End(xlDown)).Select
            'MsgBox rngAddress.Address
        Loop While rngAddress.Address <> firstAddress
    End With
End Sub