VBA/Excel/Access/Word/Excel/Name — различия между версиями

Материал из VB Эксперт
Перейти к: навигация, поиск
м (1 версия)
 
(нет различий)

Текущая версия на 12:47, 26 мая 2010

Adding Comments for a name

 
Sub addcomment()
    ActiveWorkbook.Worksheets("Sheet7").Names("LocalOffice").rument = "text"
End Sub



A name can also store the data stored in an array.

 
Sub NamedArray()
    Dim myArray(10, 5)
    Dim i As Integer, j As Integer
    For i = 1 To 10
        For j = 1 To 5
            myArray(i, j) = i + j
        Next j
    Next i
    Names.add name:="FirstArray", RefersTo:=myArray
End Sub



Checking for the Existence of a Name

 
Function NameExists(FindName As String) As Boolean
    Dim Rng As Range
    Dim myName As String
    On Error Resume Next
    myName = ActiveWorkbook.Names(FindName).Name
    If Err.Number = 0 Then
        NameExists = True
    Else
        NameExists = False
    End If
End Function



Check Name existance

 
Sub Main()
  If NameExists("SalesData") Then
    MsgBox "Name Exists"
  Else
    MsgBox "Name does not exist"
  End If
End Sub
Function NameExists(myName As String) As Boolean
  Dim X As String
  On Error Resume Next
  X = Names(myName).RefersTo
  If Err.Number <> 0 Then
    NameExists = False
    Err.Clear
  Else
    NameExists = True
  End If
End Function



Define a name by hard code the cell address

 
Sub DefineName1a()
  ActiveWorkbook.names.Add Name:="NameArea", RefersToR1C1:="=sheet1!R1C1:R3C1"
End Sub



Determining which Names Overlap a Range

 
     Sub SelectionEntirelyInNames()
         Dim sMessage As String
         Dim nmName As name
         Dim rngNameRange As range
         Dim rng As range
         On Error Resume Next
         For Each nmName In Names
             Set rngNameRange = Nothing
             Set rngNameRange = nmName.RefersToRange
             If Not rngNameRange Is Nothing Then
                 If rngNameRange.Parent.name = ActiveSheet.name Then
                    Set rng = Intersect(Selection, rngNameRange)
                    If Not rng Is Nothing Then
                        If Selection.Address = rng.Address Then
                            sMessage = sMessage & nmName.name & vbCr
                        End If
                    End If
                 End If
             End If
         Next nmName
         If sMessage = "" Then
             MsgBox "The selection is not entirely in any name"
         Else
             MsgBox sMessage
         End If
     End Sub



Enables access to named ranges in arbitrary workbooks

 
Sub ChangeValueInNamedCell2()
  Dim rng As Range
  Set rng = Evaluate(ActiveWorkbook.names("CellXy").Name)
  rng.Value = "This is a named cell."
  Debug.Print rng.Value
End Sub



Fill named range with values

 
Sub FillNameArea1()
  Application.Goto Reference:=ActiveWorkbook.Names("NameArea").Name
  Selection.value = "Test1"
End Sub
Sub FillNameArea2()
  Evaluate(ActiveWorkbook.Names("NameArea").value).value = "Test2"
End Sub



find out which names are overlapping the selected cells, regardless of whether they entirely contain the selected cells

 
     Sub NamesOverlappingSelection()
         Dim sMessage As String
         Dim nmName As name
         Dim rngNameRange As range
         Dim rng As range
         On Error Resume Next
         For Each nmName In Names
             Set rngNameRange = Nothing
             Set rngNameRange = range(nmName.name)
             If Not rngNameRange Is Nothing Then
                 If rngNameRange.Parent.name = ActiveSheet.name Then
                    Set rng = Intersect(Selection, rngNameRange)
                    If Not rng Is Nothing Then
                            sMessage = sMessage & nmName.name & vbCr
                    End If
                 End If
             End If
         Next nmName
         If sMessage = "" Then
             MsgBox "The selection is not entirely in any name"
         Else
             MsgBox sMessage
         End If
     End Sub



Generate named range from Range object

 
Sub BuildNameFromRange()
  Dim rng As Range
  Set rng = ActiveWorkbook.Sheets("sheet1").[A1].CurrentRegion
  ActiveWorkbook.Names.Add Name:="NameArea", RefersTo:="=" + rng.Address(External:=True)
  Debug.Print Range("NameArea").Address(External:=True)
End Sub



Generate Range object from named range

 
Sub BuildRangeFromName()
  Dim rng As Range
  Set rng = Evaluate(ActiveWorkbook.names("NameArea").Value)
  Debug.Print rng.Address(External:=True)
End Sub



Go to a name

 
Sub GotoName2()
  Application.Goto Reference:= ActiveWorkbook.names("NameArea").Name, Scroll:=True
End Sub



Hide a name by setting its Visible property to False

 
Sub nameRef()
     Names.add name:="StoreNumber", RefersTo:=v, Visible:=False
End Sub



Hide the name after it has been created:

 
Sub vis()
     Names("StoreNumber").Visible = False
End Sub



Insert hidden name

 
Public Sub InsertHiddenName()
  Names.Add Name:="PassWord", RefersTo:="Bazonkas", Visible:=False
End Sub



Is Name In Workbook

 
Option Explicit
Public Function IsNameInWorkbook(ByVal Name As String) As Boolean
   Dim X As String
   Dim aRange As Range
  
   Application.Volatile
   On Error Resume Next
   Set aRange = Application.Caller
   Err.Clear
   
   If aRange Is Nothing Then
      X = ActiveWorkbook.Names(Name).Name
   Else
      X = aRange.Parent.Parent.Names(Name).Name
   End If
   
   If Err.Number = 0 Then IsNameInWorkbook = True
End Function
Public Sub TestName()
  If IsNameInWorkbook(InputBox("What Name")) Then
    MsgBox "Name exists"
  Else
    MsgBox "Name does not exist"
  End If
End Sub



Names Overlapping Selection

 
Public Sub NamesOverlappingSelection()
  Dim Message As String
  Dim aName As Name
  Dim NameRange As Range
  Dim aRange As Range
 
  On Error Resume Next
  For Each aName In Names
    Set NameRange = Nothing
    Set NameRange = Range(aName.Name)
    If Not NameRange Is Nothing Then
      If NameRange.Parent.Name = ActiveSheet.Name Then
        Set aRange = Intersect(Selection, NameRange)
        If Not aRange Is Nothing Then
          Message = Message & aName.Name & vbCr
        End If
      End If
    End If
  Next aName
  If Message = "" Then
    Debug.Print "No Names are overlapping the selection"
  Else
    Debug.Print Message
  End If
End Sub



Range objects cannot be used with an worksheet object as superobject

 
Sub ChangeValueInNamedCell1()
  Range("CellXy").Value = "CellXy"
  Debug.Print Range("CellXy").Value
End Sub



Retrieving Values Stored as a Workbook Name Using the Evaluate Method

 
Sub TestWorkbookNameValue() 
    Dim vValue As Variant 
    vValue = Application.Names("SalesTaxRate").RefersTo 
    Debug.Print "Value retrieved using RefersTo: " & vValue 
End Sub



Searching for a Name

 
     Function IsNameInWorkbook(sName As String) As Boolean
         Dim s As String
         Dim rng As range
         Application.Volatile
         On Error Resume Next
         Set rng = Application.Caller
         Err.clear
         If rng Is Nothing Then
             s = ActiveWorkbook.Names(sName).name
         Else
             s = rng.Parent.Parent.Names(sName).name
         End If
         If Err.Number = 0 Then IsNameInWorkbook = True
     End Function
     Sub TestName()
           If IsNameInWorkbook(InputBox("What Name")) Then
           MsgBox "Name exists"
           Else
           MsgBox "Name does not exist"
           End If
     End Sub



Searching for the Name of a Range

 
     Sub TestNameOfRange()
         Dim nmName As name
         On Error Resume Next
         Set nmName = Selection.name
         If nmName Is Nothing Then
             MsgBox " Selection has no name"
         Else
             MsgBox nmName.name
         End If
     End Sub



Selection Entirely In Names

 
Public Sub SelectionEntirelyInNames()
  Dim Message As String
  Dim aName As Name
  Dim NameRange As Range
  Dim aRange As Range
  On Error Resume Next
  
  For Each aName In Names
    Set NameRange = Nothing
    Set NameRange = aName.RefersToRange
    If Not NameRange Is Nothing Then
      If NameRange.Parent.Name = ActiveSheet.Name Then
        Set aRange = Intersect(Selection, NameRange)
        If Not aRange Is Nothing Then
          If Selection.Address = aRange.Address Then
            Message = Message & aName.Name & vbCr
          End If
        End If
      End If
    End If
  Next aName
  If Message = "" Then
    MsgBox "The selection is not entirely in any name"
  Else
    MsgBox Message
  End If
End Sub



Select named range

 
Sub GotoName1()
  Application.Goto Reference:= _
    ActiveWorkbook.names("NameArea").Name
End Sub



specify that the Names collection belongs to a worksheet:

 
Sub nameAdd()
    Worksheets("Sheet1").Names.add name:="F", RefersToR1C1:="=Sheet1!R1C1:R6C6"
End Sub



Store formulas into names. The formula must start with an equals sign (=).

 
Sub addName()
     Names.add name:="ItemsInA", RefersTo:="=COUNTA($A:$A)"
End Sub



storing a formula in a name is the same as for a range

 
Sub addName()
    Names.add name:="Product", RefersTo:="=OFFSET(Sheet2!$A$2,0,0,COUNTA(Sheet2!$A:$A))"
End Sub



Storing Values in Names

 
Sub var()
     Dim v As Variant
     v = 3.14159
     Names.add name:="StoreNumber", RefersTo:=v
     v = "Sales"
     Names.add name:="StoreString", RefersTo:=v
End Sub



use names to store numbers between sessions

 
Sub store()
    NumofSales = 5123
    Names.add name:="TotalSales", RefersTo:=NumofSales
     "Or use this:
    Names.add name:="TotalSales", RefersTo:=5123
End Sub



use the Evaluate method equivalent to evaluate the name in VBA:

 
Sub itemA()
     Names.add name:="ItemsInA", RefersTo:="=COUNTA($A:$A)"
     MsgBox [ItemsInA]
End Sub



Using named ranges of cells

 
Option Explicit
Sub DefineName1()
  Range("A3:B5").Name = "TestArea"
  Debug.Print Range("TestArea").Address(External:=True)
End Sub



Using the Names Object to List All Named Ranges

 
Sub TestListNames()
   ListWorkbookNames ThisWorkbook, ThisWorkbook.Worksheets(2).range("a2")
End Sub
Sub ListWorkbookNames(wb As Workbook, rgListStart As range)
    Dim nm As name
    For Each nm In wb.Names
        rgListStart.value = nm.name
        rgListStart.Offset(0, 1).value = """ & nm.RefersTo
        Set rgListStart = rgListStart.Offset(1, 0)
    Next
End Sub