找到第一个“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