Find all lists in a workbook.

[Darren Bartrup]

It's been a while since I've visited MrExcel, but I've been busy learning C# & ASP.Net & Visual Studio & SQL Server - work doesn't want too much from me

Anyway, I'm writing a procedure that plays around with lists in Excel (i.e. the type of list that would show up in CurrentRegion.
They're not connected to any outside data source, or as a pivot table - just columns of data that will have a header row in a different format than the data body.

Is there any way of cycling through each sheet in the workbook and identifying each occurrence of a list?

I've been playing with the code at the bottom of the post, and it finds the boundaries of each list providing (at the moment) that each list starts on row 1. There are other problems with it however.

Basically, is there an easier way to go about this? And to identify the values in the header row?

Many thanks in advance for any help.

Darren.

For Each wrkSht In ThisWorkbook.Worksheets
    Set srchCell = wrkSht.Cells(1, 1)
    Debug.Print "Worksheet: " & wrkSht.Name
    Do Until srchCell.Column > 255
        rTble = srchCell.CurrentRegion
        If Not IsEmpty(rTble) Then
            Debug.Print "Start Row: " & srchCell.Row & " ~ End Row: " & UBound(rTble)
            Debug.Print "Start Col: " & srchCell.Column & " ~ End Col: " & srchCell.Column + UBound(rTble, 2)
            Debug.Print
        End If
        Set srchCell = srchCell.End(xlToRight)
        If IsEmpty(srchCell) Then
            Set srchCell = srchCell.End(xlToRight)
        End If
    Loop
Next wrkSht

 

[Zack Barresse]

Yes, you are correct. My apologies for my short-sightedness. This will fix what you are looking for, basically it checks the address against the current region of the address, checks if it is in a string variable we created, if not it adds it...

Sub LoopThroughRegions()
    Dim ws As Worksheet, rRegion As Range, iCnt As Long, sRegion As String
    Dim sAddys As String, arrAddys() As String, i As Long, j As Long
    For Each ws In ThisWorkbook.Worksheets
        sAddys = vbNullString
        On Error Resume Next
        sAddys = ws.Cells.SpecialCells(xlCellTypeConstants, 23).Address(0, 0)
        If sAddys = vbNullString Then GoTo SkipWs
        If InStr(1, sAddys, ",") = 0 Then
            ReDim arrAddys(1): arrAddys(1) = sAddys
        Else
            iCnt = Len(Replace(sAddys, ",", "")) - Len(sAddys)
            ReDim arrAddys(1 To iCnt): arrAddys = Split(sAddys, ",")
        End If
        For i = LBound(arrAddys) To UBound(arrAddys)
            If InStr(1, sRegion, ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0)) = 0 Then
                sRegion = sRegion & ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0) & ","
            End If
        Next i
        If Len(sRegion) > 0 Then sRegion = Left$(sRegion, Len(sRegion) - 1)
        MsgBox "Regions in sheet '" & ws.Name & "': " & sRegion, vbInformation, "REGIONS"
SkipWs:
    Next ws
End Sub

Let me know if you need a hand with this or would like comments.

 

[Darren Bartrup]

Yep, that worked almost perfectly.
The only bit that didn't work was if the list doesn't include a row & column of constant values. The sRegion would carry over the values from the previous sheet, but this was easily rectified by putting sRegion = vbNullString before the Next ws command.

I've only just realised why it was bringing back just the heading & columns - these were constants and I was filling the list with random values using =INT(RAND()*(1-100)+100). Which are obviously formula and not constants.

My bad for not saying so.

So, my understanding of the code is that it cycles through each sheet finding the constant values - I'm not sure where Address(0, 0) comes into it though. I guess it's the bit that says 'return the range reference of these cells'.
The next section dumps each individual range in the arrAddys array.
Next it looks at the region that each element of the array sits in and checks if it's been added to sRegion - if it hasn't then it adds it.
Finally, if there's anything in sRegion it displays it in a message box.

Hmmm, yep - looking at the rest of the code Address(0, 0) definately returns the range address.

Thanks for all that, you're a star! Have an MVP. Oh hang on, you've already got one

 

[Zack Barresse]

Yup, you got it!

Sorry about not having enough foresight to clear the variable. Here is an amended code which also does formulas...

Option Explicit

Sub LoopThroughRegions()
    Dim ws As Worksheet, rRegion As Range, iCnt As Long, sRegion As String
    Dim sAddys As String, arrAddys() As String, i As Long, j As Long
    For Each ws In ThisWorkbook.Worksheets
        sAddys = vbNullString
        sRegion = vbNullString
        On Error Resume Next
        sAddys = ws.Cells.SpecialCells(xlCellTypeConstants, 23).Address(0, 0) & ","
        sAddys = sAddys & ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
        If sAddys = vbNullString Then GoTo SkipWs
        If InStr(1, sAddys, ",") = 0 Then
            ReDim arrAddys(1): arrAddys(1) = sAddys
        Else
            iCnt = Len(Replace(sAddys, ",", "")) - Len(sAddys)
            ReDim arrAddys(1 To iCnt): arrAddys = Split(sAddys, ",")
        End If
        For i = LBound(arrAddys) To UBound(arrAddys)
            If InStr(1, sRegion, ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0)) = 0 Then
                sRegion = sRegion & ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0) & ","
            End If
        Next i
        If Len(sRegion) > 0 Then sRegion = Left$(sRegion, Len(sRegion) - 1)
        MsgBox "Regions in sheet '" & ws.Name & "': " & sRegion, vbInformation, "REGIONS"
SkipWs:
    Next ws
End Sub

This works in testings. The one situation where this will return funky results, but I'm not sure if it is desired or not, is say you have three ranges (and this might be better if you put data in these ranges on a blank sheet to see what I'm talking about): A1:A20, B1:J1, D5:J20. You will get a return from this routine as A1:J20, C5:J20. Now , you'll notice there is a blank row and column dividing these two ranges, but they show as two separate ranges, yet one is encompassed in the entire intersection of the other's range (C5:J20 fits fully inside of A1:J20). If this is NOT desired we'll need to change something.

 

[Darren Bartrup]

Thanks for that rewrite Zack.

I won't (shouldn't?) be encountering that one problem you pointed out - the idea is that each list will always be columns x rows in size, so I won't be getting lists sitting within lists.

I've added the code to my project with the appropriate kudos:

'//Returns each region in each worksheet within the workbook in the 'sRegion' variable.
'//
'//Written by Zack Barresse (MVP), Oregon, USA.
'//
'//http://www.mrexcel.com/forum/showthread.php?t=309052

 

[Darren Bartrup]

Quick update.

I've amended the code abit to work as a function which returns each region in an array.

So it will return for example:

• aLists(1)
  aLists(1,0) = "A1:J36"
  aLists(1,2) = "M1:V44"

• aLists(2)
  aLists(2,0) = "C1:L36"
  aLists(2,1) = Empty

• aLists(3)
  aLists(3,0) = Empty
  aLists(3,1) = Empty

With the first dimension being the index number of each sheet in the workbook.

Sub Test()
    Dim aLists  As Variant
    Dim aLists1 As Variant
    '//Find lists in a different workbook.
    aLists = FindRegionsInWorkbook(Workbooks("Test Workbook.xls"))
    '//Find lists in the this workbook.
    aLists1 = FindRegionsInWorkbook(ThisWorkbook)
    Debug.Assert False
End Sub


'//Returns each region in each worksheet within the workbook in the 'sRegion' variable.
'//
'//Written by Zack Barresse (MVP), Oregon, USA.
'//
'//http://www.mrexcel.com/forum/showthread.php?t=309052

Public Function FindRegionsInWorkbook(wrkBk As Workbook) As Variant
    Dim ws As Worksheet, rRegion As Range, iCnt As Long, sRegion As String
    Dim sAddys As String, arrAddys() As String, i As Long, j As Long
    '//Cycle through each worksheet in workbook.
    ReDim aRegions(1 To wrkBk.Worksheets.Count, 0)
    For Each ws In wrkBk.Worksheets
        sAddys = vbNullString
        sRegion = vbNullString
        On Error Resume Next
        '//Find all ranges of constant & formula valies in worksheet.
        sAddys = ws.Cells.SpecialCells(xlCellTypeConstants, 23).Address(0, 0) & ","
        sAddys = sAddys & ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
        If sAddys = vbNullString Then GoTo SkipWs
        '//Put each seperate range into an array.
        If InStr(1, sAddys, ",") = 0 Then
            ReDim arrAddys(1): arrAddys(1) = sAddys
        Else
            iCnt = Len(Replace(sAddys, ",", "")) - Len(sAddys)
            ReDim arrAddys(1 To iCnt): arrAddys = Split(sAddys, ",")
            If UBound(arrAddys) > UBound(aRegions, 2) Then
                ReDim Preserve aRegions(1 To wrkBk.Worksheets.Count, UBound(arrAddys))
            End If
        End If
        '//Place region that range sits in into sRegion (if not already in there).
        For i = LBound(arrAddys) To UBound(arrAddys)
            If InStr(1, sRegion, ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0)) = 0 Then
                sRegion = sRegion & ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0) & ","
                aRegions(ws.Index, i) = ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0)
            End If
        Next i
        '//Remove comma from end of list.
        If Len(sRegion) > 0 Then sRegion = Left$(sRegion, Len(sRegion) - 1)
        '//Display list of regions in a message box for current sheet.
        'MsgBox "Regions in sheet '" & ws.Name & "': " & sRegion, vbInformation, "REGIONS"
SkipWs:
    Next ws
    ReDim Preserve aRegions(1 To wrkBk.Worksheets.Count, UBound(arrAddys) - 1)
    FindRegionsInWorkbook = aRegions
End Function

Regards,
Darren.

 

[Zack Barresse]

Okay, I'd make a couple of changes though. First of all, dimension all the variables, so the aRegion() array needs dim'ing. Then, I would leave the address as the first variable, then the sheet name as an appended variable (concatenated). I think this works better as you get one array, and each item is fully qualified as for sheet name and address (could add workbook name and/or path if you wanted to get really ambitious).

Option Explicit

Sub Test()
    Dim aLists  As Variant
    Dim aLists1 As Variant
    '//Find lists in a different workbook.
''    aLists = FindRegionsInWorkbook(Workbooks("Test Workbook.xls"))
    '//Find lists in the this workbook.
    aLists1 = FindRegionsInWorkbook(ThisWorkbook)
    Debug.Assert False
End Sub


'//Returns each region in each worksheet within the workbook in the 'sRegion' variable.
'//
'//Written by Zack Barresse (MVP), Oregon, USA.
'//
'//http://www.mrexcel.com/forum/showthread.php?t=309052

Public Function FindRegionsInWorkbook(wrkBk As Workbook) As Variant
    Dim ws As Worksheet, rRegion As Range, sRegion As String, sCheck As String
    Dim sAddys As String, arrAddys() As String, aRegions() As Variant
    Dim iCnt As Long, i As Long, j As Long
    '//Cycle through each worksheet in workbook.
    j = 0
    For Each ws In wrkBk.Worksheets
        sAddys = vbNullString
        sRegion = vbNullString
        On Error Resume Next
        '//Find all ranges of constant & formula valies in worksheet.
        sAddys = ws.Cells.SpecialCells(xlCellTypeConstants, 23).Address(0, 0) & ","
        sAddys = sAddys & ws.Cells.SpecialCells(xlCellTypeFormulas, 23).Address(0, 0)
        If Right(sAddys, 1) = "," Then sAddys = Left(sAddys, Len(sAddys) - 1)
        On Error GoTo 0
        If sAddys = vbNullString Then GoTo SkipWs
        '//Put each seperate range into an array.
        If InStr(1, sAddys, ",") = 0 Then
            ReDim arrAddys(1 To 1, 1 To 2)
            arrAddys(1, 1) = ws.Name
            arrAddys(1, 2) = sAddys
        Else
            arrAddys = Split(sAddys, ",")
            For i = LBound(arrAddys) To UBound(arrAddys)
                arrAddys(i) = "'" & ws.Name & "'!" & arrAddys(i)
            Next i
        End If
        '//Place region that range sits in into sRegion (if not already in there).
        For i = LBound(arrAddys) To UBound(arrAddys)
            If InStr(1, sRegion, ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0)) = 0 Then
                sRegion = sRegion & ws.Range(arrAddys(i)).CurrentRegion.Address(0, 0) & "," '*** no sheet
                sCheck = Right(arrAddys(i), Len(arrAddys(i)) - InStr(1, arrAddys(i), "!"))
                ReDim Preserve aRegions(0 To j)
                aRegions(j) = Left(arrAddys(i), InStr(1, arrAddys(i), "!") - 1) & "!" & ws.Range(sCheck).CurrentRegion.Address(0, 0)
                j = j + 1
            End If
        Next i
SkipWs:
    Next ws
    On Error GoTo ErrHandle
    FindRegionsInWorkbook = aRegions
    Exit Function
ErrHandle:
    'things you might want done if no lists were found...
End Function

Let me know what you think. Tests good for me.