Excel VBA代码修复请求：To Date列数据复制及循环异常问题

Let's break down what's going wrong with your macro and fix it step by step. Your goal is to find every "To Date" cell, copy all cells below it to the adjacent left column—but right now, you're hitting an infinite loop and missing the last row after the first run.

What's Wrong with the Original Code? #

• Skipping the first match: You run .Find to get the first "To Date", then immediately call .FindNext in the Do loop—so you never process the first found cell.
• Infinite loop: The Loop While condition checks Not rngAddress Is Nothing And rngAddress <> firstAddress, but once FindNext cycles back to firstAddress, the condition fails in a way that can trap the loop, or you might not handle empty FindNext results properly.
• Unreliable range selection: Using rngAddress.End(xlDown) stops at the first blank cell, which means you won't capture all rows down to the actual last row of the sheet.
• No actual copy-paste: Your code only selects the range, but doesn't perform the core copy-and-paste action to the left column.

Corrected Macro Code #

Sub FixToDateCopy()
    Dim twb As ThisWorkbook
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim firstAddress As String
    Dim rngAddress As Range
    Const strFindMe As String = "To Date"
    
    Set twb = ThisWorkbook
    ' Loop through worksheets to target "QCR Summary"
    For Each ws In twb.Worksheets
        If ws.Name = "QCR Summary" Then
            ' Get the actual last row with data in the sheet (uses column A as reference)
            lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            ' Start searching for "To Date" in the used range of the sheet
            With ws.UsedRange
                Set rngAddress = .Find(What:=strFindMe, LookIn:=xlValues, LookAt:=xlWhole)
                If rngAddress Is Nothing Then
                    Exit Sub ' No matches found, exit early
                End If
                firstAddress = rngAddress.Address ' Store first match to avoid infinite loops
                
                Do
                    ' Define the range from the cell below "To Date" to the last row of the sheet
                    Dim copyRange As Range
                    Set copyRange = ws.Range(rngAddress.Offset(1, 0), ws.Cells(lastRow, rngAddress.Column))
                    
                    ' Copy values to the adjacent left column (no need to select ranges!)
                    copyRange.Copy
                    copyRange.Offset(0, -1).PasteSpecial xlPasteValues
                    
                    ' Move to the next match
                    Set rngAddress = .FindNext(rngAddress)
                    ' Exit loop if we're back to the first address or no more matches exist
                Loop While Not rngAddress Is Nothing And rngAddress.Address <> firstAddress
            End With
            ' Clear clipboard to remove the "marching ants" selection
            Application.CutCopyMode = False
        End If
    Next ws
End Sub

Key Fixes & Improvements #

• Process the first match: We now handle the initial found "To Date" cell before calling FindNext in the loop.
• Reliable last row calculation: Instead of relying on End(xlDown) which stops at blanks, we calculate the sheet's last data row once at the start, ensuring we always copy all rows down to the bottom of your dataset.
• Infinite loop prevention: We explicitly check if rngAddress returns to the first match address to exit the loop, and properly handle cases where FindNext returns no more results.
• Faster, cleaner execution: We avoid unnecessary range selections (VBA runs faster when working directly with range objects instead of selecting them).
• Clipboard cleanup: After pasting, we turn off CutCopyMode to clean up the clipboard and remove the visual selection highlight.

内容的提问来源于stack exchange，提问作者Sri