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