Create Named Ranges from Subtotal Group

问题

I need to create named ranges from a sheet to which I have added subtotals.

So as shown in the picture I need to create with VBA named ranges for all the groups (E4:F16 shown on the picture). The subtotals are created for each change in Column D ("Group"). The additional rows added by the subtotal wizard (Row 17 as shown) should not be included in the named range. I need to create about 10 similar named ranges in total.

The total number of rows with data on that sheet (I've named it R 14) is fixed but the number of elements within a group is variable. So for instance I need code to find out that cell A17 is empty and create a named range E4:F16.

So far I managed to create a public function that can create a named range given start row, end row, start column and end column:

Public Function createNamedRangeDynamic_1(sheetName As String, _
    myFirstRow As Long, _
    myLastRow As Long, _
    myFirstColumn As Long, _
    myLastColumn As Long, _
    counter As Integer)

    Dim myWorksheet As Worksheet
    Dim myNamedRangeDynamic As Range 'declare object variable to hold reference to cell range
    Dim myRangeName As String 'declare variable to hold defined name

    Set myWorksheet = ThisWorkbook.Worksheets(sheetName) 'identify worksheet containing cell range
    myRangeName = sheetName & "_" & counter 'specify defined name

    With myWorksheet.Cells
        Set myNamedRangeDynamic = .Range(.Cells(myFirstRow, myFirstColumn), .Cells(myLastRow, myLastColumn)) 'specify cell range
    End With
    ThisWorkbook.Names.Add Name:=myRangeName, RefersTo:=myNamedRangeDynamic 'create named range with workbook scope. Defined name is as specified. Cell range is as identified, with the last row and column being dynamically determined
End Function

My problem is that I can't make any kind of subroutine that can use the above code to produce the named ranges. I tried something like the following:

Sub makeRanges()
    Dim sheetName As String
    Dim firstRow As Long
    Dim nextRow As Long
    Dim lastRow As Long 'the lowest row of the group/range
    Dim endRow As Long 'the last row with data on the sheet
    Dim firstCol As Long
    Dim lastCol As Long
    Dim cell As Range
    Dim myWorksheet As Worksheet
    Dim counter As Integer

    sheetName = "R 14"
    firstCol = 5
    lastCol = 6
    groupNum = 9
    fistRow = 4
    endRow = 147
    counter = 1

    Set myWorksheet = ThisWorkbook.Worksheets(sheetName)

    With myWorksheet.Cells
        For Each cell In .Range("A" & firstRow, "A" & endRow)
            If cell.Value = "" Then
                nextRow = cell.Row
                Exit For
            End If
        Next cell

        lastRow = nextRow - 1

        Call createNamedRangeDynamic_1(sheetName, _
            firstRow, _
            lastRow, _
            firstCol, _
            lastCol, _
            counter) ' create named range

        firstRow = nextRow + 1
        counter = counter + 1
    End With
End Sub

So that's my progress so far.

回答1:

you can use Areas property of Range object and boil all that down to:

Option Explicit

Sub makeRanges()
    Dim sheetName As String, sheetNameForNamedRange as String
    Dim counter As Long

    sheetName = "R 14"
    sheetNameForNamedRange = Replace(sheetName, " ", "_")  ' named range name doesn't accept blanks

    Dim area As Range
    With ThisWorkbook 'reference wanted workbook
        For Each area In .Worksheets(sheetName).Range("A4:A147").SpecialCells(xlCellTypeConstants).Areas ' loop through areas of the not empty cell range along column A in 'sheetName' sheet of referenced workbook
            counter = counter + 1 ' update counter
            .Names.Add Name:=sheetNameForNamedRange & "_" & Format(counter, "00"), RefersTo:=area.Offset(, 4).Resize(, 2) ' add current named range as current area offset 4 columns to the right and wide two columns
        Next
    End With
End Sub

note: Format(counter, "00") is to have last two digits as format "_01, "_02", etc..

来源：https://stackoverflow.com/questions/50927103/create-named-ranges-from-subtotal-group

标签

excel

vba

excel-vba

named-ranges

subtotal