Прокручивайте ячейки для создания набора именованных диапазонов в VBA / Excel

Question

У меня есть трекер на моей работе, который извлекает информацию из отчета, затем информацию необходимо извлекать для каждого пользователя с именованным диапазоном.Делать это вручную - долгий и утомительный процесс - мне было интересно, есть ли способ заставить его автоматически генерировать именованные диапазоны на основе значений между двумя ячейками в столбце A.

Значения в столбце A делаютизменить и не нумеруются (но они всегда следуют одному и тому же формату).Так что в идеале это будет просто поиск следующей непустой ячейки.

Код ниже - это то, что используется для генерации именованного диапазона, но мне было интересно, можно ли было предварительно заполнить USER1, USER2, RANGE_NAME_USER1и т.д. на основе следующей непустой ячейки, чтобы она генерировала все необходимые диапазоны.

Так что, как только это будет сделано с USER1, тогда это будут USER2, USER3, RANGE_NAME_USER2 и т. Д.измените значения «USER1», «USER2», чтобы автоматически знать, что делать.

Sub SelectBetween()
    Dim findrow As Long, findrow2 As Long
    On Error GoTo errhandler
    findrow = Range("A:A").Find("USER1", Range("A1")).Row
    findrow2 = Range("A:A").Find("USER2", Range("A" & findrow)).Row
    Range("B" & findrow + 1 & ":Q" & findrow2 - 1).Select
    Selection.Name = "RANGE_NAME_USER1"
errhandler:
Exit Sub
    MsgBox "Can't find the cells! Please check!"
End Sub

Идея состоит в том, что, как только он найдет USER1 и выделит ему именованный диапазон, он будет повторять код, но будетпохоже на:

Sub SelectBetween()
    Dim findrow As Long, findrow2 As Long
    On Error GoTo errhandler
    findrow = Range("A:A").Find("USER2", Range("A1")).Row
    findrow2 = Range("A:A").Find("USER3", Range("A" & findrow)).Row
    Range("B" & findrow + 1 & ":Q" & findrow2 - 1).Select
    Selection.Name = "RANGE_NAME_USER2"
errhandler:
Exit Sub
    MsgBox "Can't find the cells! Please check!"
End Sub

Возможно ли это?Спасибо!

Answer 1

Предполагается, что пользователи отсортированы, и имена пользователей действительны как часть имени диапазона, и что вы хотите, чтобы все имена пользователей создавались как имена диапазонов.

Sub SetUserRanges()

    Dim c As Range, sht As Worksheet
    Dim usr, rngUsers As Range, n As Long

    Set sht = ActiveSheet
    Set rngUsers = sht.Range(sht.Range("A2"), sht.Cells(Rows.Count, 1).End(xlUp))
    Set c = rngUsers.Cells(1)
    Do While c.Row <= rngUsers.Cells(rngUsers.Cells.Count).Row

        usr = c.Value 'current user
        n = Application.CountIf(rngUsers, usr)

        c.Offset(0, 1).Resize(n, 16).Name = Rangename(usr)

        Set c = c.Offset(n, 0)
    Loop

End Sub

'Convert a username formatted as "Agent ####: LastName, FirstName" into 
' "FirstName_LastName"
Function Rangename(usr As String) As String
    Dim arr
    'split on ":" then split second part on ","
    arr = Split(Split(usr, ":")(1), ",")
    Rangename = Trim(arr(1)) & "_" & Trim(arr(0))
End Function

Answer 2

Думаю, это делает то, что ты хочешь. Он перебирает список названий диапазонов, поэтому подгоняет под имя, то же самое имя листа.

Sub x()

Dim rFind1 As Range, rFind2 As Range, vNames As Variant, i As Long

vNames = Array("USER1", "USER2", "USER3", "RANGE_NAME_USER2")

With Sheet1.Columns(1)
    Set rFind1 = .Cells(.Cells.Count)
    For i = LBound(vNames) To UBound(vNames) - 1
        Set rFind1 = .Find(What:=vNames(i), After:=rFind1, lookat:=xlWhole, SearchDirection:=xlNext, _
                          MatchCase:=False, SearchFormat:=False)
        If Not rFind1 Is Nothing Then
            Set rFind2 = .Find(What:=vNames(i + 1), After:=rFind1)
            If Not rFind2 Is Nothing Then
                .Range("B" & rFind1.Row + 1 & ":Q" & rFind2.Row - 1).Name = vNames(i)
            End If
        End If
    Next i
    .Range("B" & rFind2.Row + 1 & ":Q" & .Cells(Rows.Count, 2).End(xlUp).Row).Name = vNames(UBound(vNames))
End With

End Sub