Question

我试图在一个宏中运行它，但是某种程度上，该循环无法正常工作，因为当我需要将其运行直到结束时，它一直引用单元格。我正在尝试执行以下操作：

如果D列中有一个值，而B列中没有任何值，则需要复制信息。要进行复制，它将查找匹配的A列，但寻找匹配的第一行，因此B列中有值。一旦找到第一行，代码应向下复制B，E和H行

我使用的代码是一个录制的宏。这种在B中寻找值的方法将移至底部（使用Ctrl + Down）将其复制并使用Ctrl + Shift +向下（向上一个）来查找结尾。粘贴值，然后移至其他列。但是我只能让它在第一部分上运行，它需要重复直到最后。在行10000上定义结束：

Sub Sort_The_Fus_To_One_Line_2()
   Application.Goto Reference:="R8C2"
   Range("B8").Select
   Selection.End(xlDown).Select
   Selection.Copy
   Range(Selection, Selection.End(xlDown)).Select
   Range("B10:B43").Select
   ActiveSheet.Paste
   Range("E10").Select
   Application.CutCopyMode = False
   Selection.Copy
   Range(Selection, Selection.End(xlDown)).Select
   Range("E10:E43").Select
   ActiveSheet.Paste
   Range("H10").Select
   Application.CutCopyMode = False
   Selection.Copy
   Range(Selection, Selection.End(xlDown)).Select
   Range("H10:H43").Select
   ActiveSheet.Paste
   Range("B10").Select
   Selection.End(xlDown).Select
End Sub

有人可以帮忙吗？谢谢！

Answer 1

我认为这就像您追求的一样：

Sub Test()

    Dim rStart As Range, rEnd As Range
    Dim FirstAdd As String
    Dim lLastRow As Long

    lLastRow = 10001

    With Worksheets("Sheet1").Columns(2)
        'Find the first non-blank cell in column B.
        Set rStart = .Find(What:="*", _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchDirection:=xlNext)

        'rStart will be Nothing if the column is empty.
        If Not rStart Is Nothing Then
            FirstAdd = rStart.Address 'Very first found address.

            Do
                'Find the next non-blank cell in column B.
                Set rEnd = .FindNext(rStart)

                If rEnd.Row < rStart.Row And rStart.Row < lLastRow Then
                    'The cell reference is relative to the column in the With command.
                    'making column 1 = sheet column 2.
                    Set rEnd = .Cells(lLastRow, 1)
                End If

                'If the second address isn't the same as the very first address and
                'the second address isn't the row below the start address then copy the value down.
                If rEnd.Address <> FirstAdd And rStart.Offset(1).Address <> rEnd.Address Then

                    'Places the value from the Start row into every cell between one below the
                    'start row to one cell above the end row.
                    Worksheets("Sheet1").Range(rStart.Offset(1), rEnd.Offset(-1)) = rStart.Value
                    Worksheets("Sheet1").Range(rStart.Offset(1), rEnd.Offset(-1)).Offset(, 3) = rStart.Offset(, 3).Value
                    Worksheets("Sheet1").Range(rStart.Offset(1), rEnd.Offset(-1)).Offset(, 6) = rStart.Offset(, 6).Value
                End If

                'Set the new start address as the previous end address.
                Set rStart = rEnd

            Loop While rStart.Row < lLastRow
        End If
    End With

End Sub

VBA向下复制信息但循环进行

1 个答案: