从小计组创建命名范围

Question

我需要从添加了小计的 sheet 创建命名范围。

所以如图所示，我需要为所有组创建 VBA 命名范围（如图所示 E4:F16）。为 Column D ("Group") 中的每个更改创建小计。小计向导添加的附加行（Row 17，如图所示）不应包含在命名范围内。我总共需要创建大约 10 个类似的命名范围。

sheet（我将其命名为 R 14）数据的总行数是固定的，但组内的元素数是可变的。因此，例如我需要代码来找出单元格 A17 是空的并创建一个命名范围 E4:F16.

到目前为止，我设法创建了一个 public 函数，它可以在给定起始行、结束行、起始列和结束列的情况下创建命名范围：

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

我的问题是我无法创建任何一种可以使用上述代码生成命名范围的子例程。我尝试了如下操作：

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

这就是我目前的进度。

Answer 1

您可以使用 Range 对象的 Areas 属性并将所有内容归结为：

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

注意：Format(counter, "00") 的最后两位数字格式为“_01、“_02”等。

从小计组创建命名范围

Create Named Ranges from Subtotal Group

excel

vba

subtotal

named-ranges