Select直到不等于范围

Question

我有一千行 Excel 工作表，看起来像这样。

我在循环中遇到了困难。我需要做的是从第一个单元格（即“002”）和 select 开始，直到单元格不等于第一个单元格（在本例中为“007”之前的单元格）。然后复制（或剪切，因为下一个循环将从“007”开始）并将其粘贴到另一个工作簿。

我这里有我现有的代码。


Dim s_cell As Range
Dim c_cell As Range

Set s_cell = Range("AM2")

Do Until ActiveCell.Offset(1) <> s_cell
    On Error Resume Next
    c_cell = ActiveRange
    Range(c_cell, AcitveCell.Offset(1)).Select
Loop

End Sub

如果我可以创建一个代码来自动化这个想法，它将最大限度地减少此工作负载所需的时间。

Answer 1

像这样计算与 ActiveCell 匹配的单元格数：

Sub SelectActiveCellMatches()
    If Len(ActiveCell) = 0 Then Exit Sub
    Dim Count As Long
    
    Do
        Count = Count + 1
    Loop Until ActiveCell.Offset(Count).Value <> ActiveCell.Value

   ActiveCell.Resize(Count).Select
    
End Sub

Answer 2

部分自动化：复制列组

这会将与所选内容的第一个单元格相等的所有底部连续单元格复制到剪贴板，但仅在选择最后一个单元格下方的单元格之后。

Option Explicit

Sub CopyColumnGroup()
    Const ProcName As String = "CopyColumnGroup"
    On Error GoTo ClearError
    
    With Selection.Cells(1)
        Dim cCell As Range: Set cCell = .Cells
        Dim cValue As Variant: cValue = .Value
        Do While cCell.Value = cValue
           Set cCell = cCell.Offset(1)
        Loop
        cCell.Select
        .Resize(cCell.Row - .Row).Copy
    End With

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

Answer 3

你可以循环检查下一个值是否相同：

Sub test()
Dim i As Long
Dim j As Long
Dim LR As Long

LR = Range("A" & Rows.Count).End(xlUp).Row
j = 2 'starting row of data

For i = 2 To LR Step 1
    If Range("A" & i + 1).Value <> Range("A" & i).Value Then
        'next value is different, target range would be
        Debug.Print Range("A" & j & ":A" & i).Address
        j = i + 1
    End If
Next i
End Sub

这段代码的输出是：

$A:$A
$A:$A
$A
$A:$A

这些是您要复制或执行任何操作的连续值范围。请注意，即使该值只出现一次，它也能正常工作。要调用目标范围，请使用显示 Range("A" & j & ":A" & i) 的代码部分。这将采用所有以相同值开始和结束的连续单元格。

Select直到不等于范围

Select Until Not Equal Range

indexing

excel

vba

loops

部分自动化：复制列组