Benannte Bereiche - Named Ranges...

Frage: In Spalte D stehen verschiedene Einträge (z. B. Buch, Magazin...). Für alle unterschiedlichen Einträge benötige ich einen benannten Bereich bezogen auf Spalte E. Wie geht das?

In column D different entries (eg book, magazine ...). For all the different items I need a named range relative to column E. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Benannte Bereiche - Named Ranges...[XLS 40 KB]

' Require Variable Declaration
Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 23.10.2013
' Purpose   : Create named ranges - different entries in column D...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variable Declaration
    Dim rngUnion As Range
    Dim lngRow As Long
    On Error GoTo Fin
    ' This macro is invoked only for testing - the call can later be deleted
    Call Main_1
    ' All objects related to Sheet1 - MUST begin with a dot
    With Sheet1
        ' Determine the last occupied cell in column D
        lngRow = IIf(IsEmpty(.Cells(.Rows.Count, 4)), _
            .Cells(.Rows.Count, 4).End(xlUp).Row, .Rows.Count)
        ' Loop from row 2 to the last row
        For lngRow = 2 To lngRow
            ' If the entry in the cell is equal to
            ' the entry in the next cell, then ...
            If .Cells(lngRow, 4).Value <> .Cells(lngRow + 1, 4).Value Then
                ' If the object variable "rngUnion" is not yet occupied, then...
                If Not rngUnion Is Nothing Then
                    ' Set the object variable "rngUnion" in relation
                    ' to the corresponding cell address
                    Set rngUnion = Application.Union(rngUnion, .Cells(lngRow, 5))
                    ' Create a named range
                    ThisWorkbook.Names.Add Name:=.Cells(lngRow, 4).Value, _
                        RefersTo:="=" & .Name & "!" & rngUnion.Address
                    ' Reset the object variable
                    Set rngUnion = Nothing
                End If
            ' Otherwise...
            Else
                ' If the object variable "rngUnion" is not yet occupied, then...
                If Not rngUnion Is Nothing Then
                    ' Set the object variable "rngUnion" in relation
                    ' to the corresponding cell address
                    Set rngUnion = Application.Union(rngUnion, .Cells(lngRow, 5))
                ' Otherwise...
                Else
                    ' The object variable "rngUnion" is created the first time
                    Set rngUnion = .Cells(lngRow, 5)
                End If
            End If
        ' The next cell
        Next lngRow
    End With
    ' This macro is invoked only for testing - the call can later be deleted
    Call Main_1
Fin:
    ' Reset the object variable
    Set rngUnion = Nothing
    ' If an error occurs print it out with the error number and description
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
' This subroutine is only needed to test
Private Sub Main_1()
    Dim strTMP As String
    Dim objName As Name
    If ThisWorkbook.Names.Count > 0 Then
        For Each objName In ThisWorkbook.Names
            strTMP = strTMP & objName.Name & " " & objName.RefersTo & vbCrLf
        Next objName
    Else
        MsgBox "No named ranges available!"
    End If
    If strTMP <> "" Then MsgBox strTMP
End Sub
' With this routine, all named ranges are deleted.
Public Sub Names_Delete()
    Dim objName As Name
    On Error GoTo Fin
    For Each objName In ThisWorkbook.Names
        objName.Delete
    Next objName
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...