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

Question

我需要您的帮助来修复此代码。此代码的目标是设置一个范围。找到第一个“To Date”，然后选择“To Date”下的所有单元格，将值粘贴到前面的单元格中（例如，第一个“To Date”在单元格 F4 中包含来自 F5:F“N”的值（N=最后一行）然后将 F5:F"N" 值粘贴到 E5:E"N" 中，然后转到下一个 To Date。

我在这段代码中面临的问题是

1. 代码不会选择“To Date”下的最后一行（第一次除外）

2. 无限循环运行的代码不会在最后一个“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

因为您将变量命名为 rngAddress，所以名称表明该变量包含一个地址字符串，而实际上它包含一个 Range 对象。

然后你比较 rngAddress <> firstAddress 但如果你看看你的变量声明

Dim firstAddress As String
Dim rngAddress As Range

您看到您将Range 对象与无法正常工作的String 进行比较。因为rngAddress 是一个范围对象，它默认为rngAddress.Value，所以你实际上将单元格rngAddress 的值与地址字符串firstAddress 进行比较。

替换

Loop While Not rngAddress Is Nothing And rngAddress <> firstAddress

与

Loop While rngAddress.Address <> firstAddress

请注意，您可以在循环中省略 Not rngAddress Is Nothing 部分，因为这永远不会发生。如果它是Nothing，那么在您之前检查If rngAddress Is Nothing Then 的步骤中，它已经是Exit Sub。

还有Dim twb As ThisWorkbook，这应该是错误的，因为它必须是Dim twb As Workbook。

最后，您的循环有点不必要，因为您可以直接访问名为 QCR Summary 的工作表，而无需遍历所有工作表。哪个会更快：

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