VBA Dynamic Ranges

Question

I wonder whether someone may be able to help me please.

I've put together the code below which creates a new sheet in my workbook and applies dynamic named ranges and page formatting.

Sub AllDataNamedRanges()

Dim rLOB As Range
Dim rStaffName As Range
Dim rTask As Range
Dim rProjectName As Range
Dim rProjectID As Range
Dim rJobRole As Range
Dim rMonth As Range
Dim rActuals As Range

Set rLOB = Range([B4], [B4].End(xlDown))
Set rStaffName = Range([C4], [C4].End(xlDown))
Set rTask = Range([D4], [D4].End(xlDown))
Set rProjectName = Range([E4], [E4].End(xlDown))
Set rProjectID = Range([F4], [F4].End(xlDown))
Set rJobRole = Range([G4], [G4].End(xlDown))
Set rMonth = Range([H4], [H4].End(xlDown))
Set rActuals = Range([I4], [I4].End(xlDown))

Sheets("AllData").Select

    ActiveWorkbook.Names.Add Name:="LOB", RefersToR1C1:="=" & _
    ActiveSheet.Name & "!" & rLOB.Address(ReferenceStyle:=xlR1C1)

    ActiveWorkbook.Names.Add Name:="StaffName", RefersToR1C1:="=" & _
    ActiveSheet.Name & "!" & rStaffName.Address(ReferenceStyle:=xlR1C1)

    ActiveWorkbook.Names.Add Name:="Task", RefersToR1C1:="=" & _
    ActiveSheet.Name & "!" & rTask.Address(ReferenceStyle:=xlR1C1)

    ActiveWorkbook.Names.Add Name:="ProjectName", RefersToR1C1:="=" & _
    ActiveSheet.Name & "!" & rProjectName.Address(ReferenceStyle:=xlR1C1)

    ActiveWorkbook.Names.Add Name:="ProjectID", RefersToR1C1:="=" & _
    ActiveSheet.Name & "!" & rProjectID.Address(ReferenceStyle:=xlR1C1)

    ActiveWorkbook.Names.Add Name:="JobRole", RefersToR1C1:="=" & _
    ActiveSheet.Name & "!" & rJobRole.Address(ReferenceStyle:=xlR1C1)

    ActiveWorkbook.Names.Add Name:="Month", RefersToR1C1:="=" & _
    ActiveSheet.Name & "!" & rMonth.Address(ReferenceStyle:=xlR1C1)

    ActiveWorkbook.Names.Add Name:="Actuals", RefersToR1C1:="=" & _
    ActiveSheet.Name & "!" & rActuals.Address(ReferenceStyle:=xlR1C1)

End Sub

The code does work but I'm a little concerned that it may be a little clunky and could be written smarter. I'm relatively new to VBA but I'm willing to learn.

I just wondered whether someone, who is perhaps a more seasoned programmer than I, could look at this please and offer some guidance on how I may be able to write this a little better.

Many thanks and kind regards

Answer 1

I agree with ooo's answer: if you can use the power of Excel instead of VBA do. However, I must object to:

Set rLOB = Range([B4], [B4].End(xlDown))

End(xlDown) does not define the last used row which is what I assume you want. If cell B4 is blank and there are no used cells below it, it sets rLOB to B4 down to the bottom of the column. If cell B4 is blank and there are used cells below B4, it sets rLOB to B4 down to the first non-blank cell. If B4 is non-blank, it sets rLOB from B4 down to the cell before the next blank cell.

If there are blank cells, each column's range will be down to a different row.

Finding the last used row or column, if that is what you, can be tricky with no method giving you the correct result in every situation.

Create an empty workbook, place the code below in a module and run the macro. It shows a selection of techniques and the problems with each. Hope this helps.

Option Explicit
Sub FindFinal()

  Dim Col As Long
  Dim Rng As Range
   Dim Row As Long

  ' Try the various techniques on an empty worksheet
  Debug.Print "***** Empty worksheet"
  Debug.Print ""

  With Worksheets("Sheet1")

    .Cells.EntireRow.Delete

    Set Rng = .UsedRange
    If Rng Is Nothing Then
      Debug.Print "Used range is Nothing"
    Else
      Debug.Print "Top row of used range is: " & Rng.Row
       Debug.Print "Left column row of used range is: " & Rng.Column
      Debug.Print "Number of rows in used range is: " & Rng.Rows.Count
      Debug.Print "Number of columns in used range is: " & Rng.Columns.Count
       Debug.Print "!!! Notice that the worksheet is empty but the user range is not."
    End If

    Debug.Print ""

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
     If Rng Is Nothing Then
      Debug.Print "According to Find the worksheet is empty"
    Else
      Debug.Print "According to Find the last row containing a value is: " & Rng.Row
    End If

    Debug.Print ""
    Set Rng = .Cells.SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      Debug.Print "According to SpecialCells the worksheet is empty"
    Else
      Debug.Print "According to SpecialCells the last row is: " & Rng.Row
       Debug.Print "According to SpecialCells the last column is: " & Rng.Column
    End If

    Debug.Print ""
    Row = .Cells(1, 1).End(xlDown).Row
    Debug.Print "Down from A1 goes to: A" & Row
     Row = .Cells(Rows.Count, 1).End(xlUp).Row
    Debug.Print "up from A" & Rows.Count & " goes to: A" & Row
    Col = .Cells(1, 1).End(xlToRight).Column
    Debug.Print "Right from A1 goes to: " & ColNumToCode(Col) & "1"
     Col = .Cells(1, Columns.Count).End(xlToLeft).Column
    Debug.Print "Left from " & Columns.Count & _
                "1 goes to: " & ColNumToCode(Col) & "1"

    ' Add some values and formatting to worksheet

    .Range("A1").Value = "A1"
    .Range("A2").Value = "A2"
    For Row = 5 To 7
      .Cells(Row, "A").Value = "A" & Row
     Next
    For Row = 12 To 15
      .Cells(Row, 1).Value = "A" & Row
    Next

    .Range("B1").Value = "B1"
    .Range("C2").Value = "C2"
    .Range("B16").Value = "B6"
     .Range("C17").Value = "C17"

    .Columns("F").ColumnWidth = 5
    .Cells(18, 4).Interior.Color = RGB(128, 128, 255)
    .Rows(19).RowHeight = 5

    Debug.Print ""
     Debug.Print "***** Non-empty worksheet"
    Debug.Print ""

    Set Rng = .UsedRange
    If Rng Is Nothing Then
      Debug.Print "Used range is Nothing"
    Else
      Debug.Print "Top row of used range is: " & Rng.Row
       Debug.Print "Left column row of used range is: " & Rng.Column
      Debug.Print "Number of rows in used range is: " & Rng.Rows.Count
      Debug.Print "Number of columns in used range is: " & Rng.Columns.Count
       Debug.Print "!!! Notice that row 19 which is empty but has had its height changed is ""used""."
      Debug.Print "!!! Notice that column 5 which is empty but has had its width changed is not ""used""."
       Debug.Print "!!! Notice that column 4 which is empty but contains a coloured cell is ""used""."
    End If

    Debug.Print ""

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
     If Rng Is Nothing Then
      Debug.Print "According to Find the worksheet is empty"
    Else
      Debug.Print "According to Find the last row containing a formula is: " & Rng.Row
    End If
     ' *** Note: search by columns not search by rows ***
    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
    If Rng Is Nothing Then
      Debug.Print "According to Find the worksheet is empty"
     Else
      Debug.Print "According to Find the last column containing a formula is: " & Rng.Column
    End If
    ' *** Note: Find returns a single cell and the nature of the search
    '           affects what it find.  Compare SpecialCells below.

    Debug.Print ""
    Set Rng = .Cells.SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      Debug.Print "According to SpecialCells the worksheet is empty"
    Else
      Debug.Print "According to SpecialCells the last row is: " & Rng.Row
       Debug.Print "According to SpecialCells the last column is: " & Rng.Column
    End If

    Debug.Print ""
    Row = 1
    Do While True
      Debug.Print "Down from A" & Row & " goes to: ";
       Row = .Cells(Row, 1).End(xlDown).Row
      Debug.Print "A" & Row
      If Row = Rows.Count Then Exit Do
    Loop

  End With

  With Worksheets("Sheet2")

    .Cells.EntireRow.Delete

  .Range("B2").Value = "B2"
  .Range("C3").Value = "C3"
  .Range("B7").Value = "B7"
  .Range("B7:B8").Merge
   .Range("F3").Value = "F3"
  .Range("F3:G3").Merge

    Debug.Print ""
    Debug.Print "***** Try with merged cells"

    Set Rng = .UsedRange
     If Rng Is Nothing Then
      Debug.Print "Used range is Nothing"
    Else
      Debug.Print "Used range is: " & Replace(Rng.Address, "$", "")
    End If

     Debug.Print ""
    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      Debug.Print "According to Find the worksheet is empty"
     Else
      Debug.Print "According to Find the last cell by row is: " & Replace(Rng.Address, "$", "")
    End If
    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
     If Rng Is Nothing Then
      Debug.Print "According to Find the worksheet is empty"
    Else
      Debug.Print "According to Find the last cell by column is: " & Replace(Rng.Address, "$", "")
     End If
      Debug.Print "!!! Notice that Find can ""see"" B7 but not F3."

    Debug.Print ""
    Set Rng = .Cells.SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
       Debug.Print "According to SpecialCells the worksheet is empty"
    Else
      Debug.Print "According to SpecialCells the last row is: " & Rng.Row
      Debug.Print "According to SpecialCells the last column is: " & Rng.Column
     End If

  End With

End Sub
Function ColNumToCode(ByVal ColNum As Long) As String

  Dim Code As String
  Dim PartNum As Long

  ' Last updated 3 Feb 12.  Adapted to handle three character codes.
   If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    Code = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      Code = Chr(65 + PartNum) & Code
      ColNum = (ColNum - PartNum - 1) \ 26
     Loop
  End If

End Function

Answer 2

The best way is not to do it via code at all but use a dynamic named range which will change the range as you add new data.

The named range formula below sets a dynamic named range covering range Sheet1!$A$4:$A$1000

=OFFSET(Sheet1!$A$4,0,0,COUNTA(Sheet1!$A$4:$A$1000),1)

1. Formulas/Name Manager
2. New
3. Enter Name, scope, and refers to formula above (comments are optional)
4. OK

You could also use the whole column A:A but if you start counting from A4 then you need to adjust for the number of cells with value in A1:A3. In the picture example it would be

=OFFSET(Sheet1!$A$4,0,0,COUNTA(Sheet1!$A:$A)-1,1)