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

编程问答 2022-06-07

问题描述

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

enter image description here

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

  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("*",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

解决方法

因为您将变量命名为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，那么在您选中Exit Sub的先前步骤中，它已经有If rngAddress Is Nothing Then。

还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("*",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
excelexcelexcel-2010vba