VBA code to Capture values & ranges of all different values in a column

[johnnyL]

Trying to capture all values found in a column as well as the ranges of those values found in a column.
Not just the Unique values.

Loading the initial column range of values into an array type vehicle is not allowed.


I will attach the code I came up with, I am asking what is the faster way to do it because the range involved will actually be many thousands of rows.

Sub FindRangesForSameValuesInColumn()
'
    Application.ScreenUpdating = False                                                          ' Turn ScreenUpdating off
'
    Dim InitialValue                As Boolean
    Dim CellValueCounter            As Long
    Dim cell                        As Range, ColumnRange       As Range
    Dim CurrentCellValue            As Single, StoredCellValue  As Single
    Dim CurrentCellAddress          As String, CurrentCellRange As String
    Dim CellValueArray              As Variant, CellRangeArray  As Variant
'
    CellValueCounter = 0                                                                        ' Initialize CellValueCounter
     StoredCellValue = 0                                                                        ' Initialize StoredCellValue
'
    ReDim CellRangeArray(1 To 50000)                                                            ' Set initial size of CellRangeArray to a large size
    ReDim CellValueArray(1 To 50000)                                                            ' Set initial size of CellValueArray to a large size
'
    Set ColumnRange = Range("A1:A20")                                                           ' Set the column range to search through
'
    For Each cell In ColumnRange                                                                ' Loop through each cell in the range
        CurrentCellAddress = cell.Address(0, 0)                                                 '   Get the current cell address ... A1
'
        CurrentCellValue = Range("" & CurrentCellAddress & "").Value                            '   Gets the current cell row value ... 10.5
'
        If CurrentCellValue = StoredCellValue Then                                              '   If same value found then ...
            CurrentCellRange = Split(CurrentCellRange, ":")(0) & ":" & CurrentCellAddress       '       Correct the end of the range with new cell address
            CellRangeArray(CellValueCounter) = """" & CurrentCellRange & """"                   '       Save new range into CellRangeArray
        Else                                                                                    '   If new value found then ...
            InitialValue = True                                                                 '       Set New value flag
            StoredCellValue = CurrentCellValue                                                  '       Save new cell value into StoredCellValue
            CellValueCounter = CellValueCounter + 1                                             '       Increment CellValueCounter
            CellValueArray(CellValueCounter) = StoredCellValue                                  '       Save new cell value into CellValueArray
            CurrentCellRange = CurrentCellAddress & ":"                                         '       Save new range start address into CurrentCellRange
'
            If StoredCellValue <> Range("" & CurrentCellAddress & "").Offset(0, 1).Value & _
                    Not InitialValue Then                                                       '       If StoredCellValue <> next value & this isn't the
'                                                                                               '           first time for the value then ...
                        CellRangeArray(CellValueCounter) = """" & _
                        CurrentCellRange & Split(CurrentCellRange, ":")(0) & """"               '               Save single range into CellRangeArray
            End If
'
            InitialValue = False                                                                '       Set InitialValue to False
        End If
    Next                                                                                        ' Loop back
'
    ReDim Preserve CellValueArray(1 To CellValueCounter)                                        ' Resize the CellValueArray to actual size of array
    ReDim Preserve CellRangeArray(1 To CellValueCounter)                                        ' Resize the CellRangeArray to actual size of array
'
    Range("D2").Resize(UBound(CellValueArray)) = Application.Transpose(CellValueArray)          ' Display the contents of the CellValueArray
    Range("E2").Resize(UBound(CellRangeArray)) = Application.Transpose(CellRangeArray)          ' Display the contents of the CellRangeArray
'
    Application.ScreenUpdating = True                                                           ' Turn ScreenUpdating back on
End Sub

Here is a small sample of data:

ExcelFileSizeReducerV1.xlsm
	A	B	C	D	E	F
1	10.5			Desired Value	Desired Range
2	10.5			10.5	"A1:A4"
3	10.5			19	"A5:A6"
4	10.5			10.25	"A7:A7"
5	19			6	"A8:A14"
6	19			10.5	"A15:A17"
7	10.25			17	"A18:A20"
8	6
9	6
10	6
11	6
12	6
13	6
14	6
15	10.5
16	10.5
17	10.5
18	17
19	17
20	17
21
Sheet2

 

[Alex Blakenburg]

Loading the initial column range of values into an array type vehicle is not allowed

Why not ?

 

[johnnyL]

Why not ?

Because that is part of the test.

 

[Alex Blakenburg]

How about

Sub FindRangesForSameValuesInColumn_ABv01()

    Dim rng As Range, rngFirstRow As Long
    Dim i As Long, iOut As Long, startRow As Long, endRow As Long
    Dim arrOut() As Variant
   
    Range("D2").CurrentRegion.Offset(1).ClearContents
   
    If Range("A1") = "" Then
        rngFirstRow = Range("A1").End(xlDown).Row
    Else
        rngFirstRow = 1
    End If
   
    Set rng = Range("A" & rngFirstRow & ":A" & Cells(Rows.Count, "A").End(xlUp).Row)
    ReDim arrOut(1 To rng.Rows.Count, 1 To 2)
   
    startRow = rng.Cells(1, 1).Row
    iOut = 0
    For i = rngFirstRow To rng.Rows.Count + rngFirstRow
        If Cells(i, "A") <> Cells(i + 1, "A") Then
            endRow = Cells(i, "A").Row
            iOut = iOut + 1
            arrOut(iOut, 1) = Cells(i, "A").Value
            arrOut(iOut, 2) = """" & "A" & startRow & ":" & "A" & endRow & """"
            startRow = endRow + 1
        End If
    Next i
   
    Range("D2").Resize(iOut, 2).Value = arrOut
   
End Sub

 

[kvsrinivasamurthy]

Try this code. Faster one.
Data range Starts from A1. Result range starts from F2. Change both as required.

Sub GetRanges()
Dim M
Dim Rng As Range, Rng1 As Range
Dim  X$, T&

Set Rng = Range("A1").CurrentRegion
Set Rng1 = Rng.Offset(1, 0)

ReDim A(0 To Rng.Cells.Count, 1 To 2)

A(0, 1) = Rng.Cells(1, 1): X = Rng.Cells(1, 1).Address
M = Filter(Evaluate("Transpose(If(" & Rng.Address & "<>" & Rng1.Address & " ,ROW(" & Rng.Address & "),False))"), False, False)

For T = 0 To UBound(M)
A(T + 1, 1) = Rng.Cells(M(T) + 1, 1): A(T, 2) = X & ":" & Rng.Cells(M(T), 1).Address
X = Rng.Cells(M(T) + 1, 1).Address
Next T
 With Range("F2").Resize(T + 2, 2)
 .Clear
.Value = A
End With

End Sub

 

[johnnyL]

Than you @Alex Blakenburg & @kvsrinivasamurthy for both of your responses. They are both better than what I had originally came up with.

They both are pretty fast. Without doing any time tests for more cells, it seemed that @kvsrinivasamurthy ran slightly faster on the code posted. I am only guessing, that if more cells were tested then @kvsrinivasamurthy code would prevail in a more noticeable fashion.