Vba to list value and row range occupied down entire column

[michaelsmith559]

In the example, I am going down column B. Column F lists the values and Column G lists the row range for that value. I want to be able to do this for each column. The columns start in row 1 and go until row 1048576. Looking for a quick vba solution for the problem. Thanks for any help.

Book1
	A	B	C	D	E	F	G
1	10	15	32	37	44	Value	Rows
2	10	15	32	37	45	15	1
3	10	15	32	37	46		8991
4	10	15	32	37	47	16	8992
5	10	15	32	37	48		33795
6	10	15	32	37	49	17	33796
7	10	15	32	37	50		57221
8	10	15	32	37	51	15	437883
9	10	15	32	37	52		464117
10	10	15	32	37	53
11	10	15	32	37	54
12	10	15	32	37	55
13	10	15	32	37	56
14	10	15	32	37	57
15	10	15	32	37	58
Sheet1

 

[Trebor76]

Hi Michael,

Not sure why there's such a jump in rows from 17 to 15 but assuming there's numbers in every Row of Col. B here's one possible solution:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim dblValue As Double
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet4") '<-Change to the sheet name where the data resides
    
    With wsSrc
        j = .Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For i = 1 To j
            If i = 1 Then
                k = .Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                'Clear any existing entries
                If k >= 2 Then
                    .Range("F2:G" & k).ClearContents
                    k = .Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                End If
                .Range("F" & k).Offset(1, 0).Value = .Range("B" & k).Value
                .Range("G" & k).Offset(1, 0).Value = i
                dblValue = .Range("B" & i).Value
            Else
                If .Range("B" & i).Value <> dblValue Then
                    k = .Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    .Range("G" & k).Value = i - 1
                    dblValue = .Range("B" & i).Value
                    .Range("F" & k).Offset(1, 0).Value = dblValue
                    .Range("G" & k).Offset(1, 0).Value = i
                End If
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[michaelsmith559]

Hi Michael,

Not sure why there's such a jump in rows from 17 to 15 but assuming there's numbers in every Row of Col. B here's one possible solution:

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim dblValue As Double
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet4") '<-Change to the sheet name where the data resides
   
    With wsSrc
        j = .Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For i = 1 To j
            If i = 1 Then
                k = .Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                'Clear any existing entries
                If k >= 2 Then
                    .Range("F2:G" & k).ClearContents
                    k = .Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                End If
                .Range("F" & k).Offset(1, 0).Value = .Range("B" & k).Value
                .Range("G" & k).Offset(1, 0).Value = i
                dblValue = .Range("B" & i).Value
            Else
                If .Range("B" & i).Value <> dblValue Then
                    k = .Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    .Range("G" & k).Value = i - 1
                    dblValue = .Range("B" & i).Value
                    .Range("F" & k).Offset(1, 0).Value = dblValue
                    .Range("G" & k).Offset(1, 0).Value = i
                End If
            End If
        Next i
    End With
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Thanks for the help. Just tried it out. Works great. Appreciate it very much.

 

[Trebor76]

Thanks for the help. Just tried it out. Works great. Appreciate it very much.

Thanks for letting know and you're welcome