Select Until Not Equal Range-CodePudding

I have a thousand rows of Excel worksheet that looks like this.

I encountered difficulties in loop. What do I need to do is start from the first cell (i.e. "002") and select until the cell is not equal to first cell (in this example, the cell before "007"). Then copy (or cut, since the next loop will start at "007") and paste it to another workbook.

I have my existing code here.


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

If I can just create a code that will automate this idea, it will minimize the time required in this workload.

CodePudding user response：

Count the number of cells that match the ActiveCell like this:

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

CodePudding user response：

Partial Automation: Copy a Column Group

This will copy all consecutive cells towards the bottom that are equal to the first cell of the selection to the clipboard, but only after selecting the cell below the last.

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

CodePudding user response：

You could loop and check if next value is same or not:

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

The output of this code is:

$A$2:$A$5
$A$6:$A$7
$A$8
$A$9:$A$11

Those are the consecutive ranges by value you want to copy or do whatever you want. Notice it works even if the value appears just once. To call the target range use the part of code that says Range("A" & j & ":A" & i). This will take all consecutive cells that start and end with same value.