Results 1 to 2 of 2

Thread: Excel: Create ranges for date and blank cells

  1. #1

    Thread Starter
    Former Admin/Moderator MartinLiss's Avatar
    Join Date
    Sep 1999
    Location
    San Jose, CA
    Posts
    33,431

    Excel: Create ranges for date and blank cells

    In column 'A' I have data that looks like this starting in row 3. The number of dates and blanks between the dates are variable. I'd like to do it without stepping through every row.
    Date
    Blank
    Blank
    Blank
    Date
    Blank
    Blank
    Blank
    Blank

    In a loop starting in row 3 I'd like to set a range with an address of A3:A6, and then set a second range with an address of A7:A50. The 50 is a hard-coded value to prevent the range from being A7:A1048576.

    Thanks in advance for the help.

  2. #2
    PowerPoster Zvoni's Avatar
    Join Date
    Sep 2012
    Location
    To the moon and then left
    Posts
    5,264

    Re: Excel: Create ranges for date and blank cells

    Since you say "Loop" i take it it's vba.
    If you're alread in a loop, what's wrong with checking the cells in Column A if they're empty/blank?
    Some speed up might be gained with
    Code:
    Public Function GetLastRow(ByVal ASheetName As String, Optional ByVal AColumn As String = "A") As Long
        GetLastRow = Worksheets(ASheetName).Cells(Worksheets(ASheetName).Rows.Count, AColumn).End(xlUp).Row
    End Function
    Pass the Sheetname, and you get the last non-empty row in column A (for your second range "A7:A50" that would be 7)

    Aircode
    Code:
    Public Function GetLastRow(ByVal ASheetName As String, Optional ByVal AColumn As String = "A") As Long
        GetLastRow = Worksheets(ASheetName).Cells(Worksheets(ASheetName).Rows.Count, AColumn).End(xlUp).Row
    End Function
    
    Sub SetRangeName(ByRef ASheetName As String)
    Dim lr As Long
    Dim i As Long
    Dim j As Long
    Dim c As Long
    Dim b As Boolean
    Dim ws As Worksheet
    Dim arrRanges() As Range
        c = 0
        Set ws = Worksheets(ASheetName)
        ReDim arrRanges(0 To c)
        lr = GetLastRow(ASheetName)
        b = True
        For i = 3 To lr
            If ws.Cells(i, 1) <> "" Then
                If b Then
                    j = i
                    b = False
                Else
                    Set arrRanges(c) = ws.Range("$A$" & j & ":$A$" & i - 1)
                    ReDim Preserve arrRanges(0 To c + 1)
                    c = UBound(arrRanges)
                    j = i
                End If
            End If
        Next
        Set arrRanges(c) = ws.Range("$A$" & lr & ":$A$50")
    End Sub
    
    Sub Test()
        SetRangeName "Sheet1"
    End Sub
    Last edited by Zvoni; Tomorrow at 31:69 PM.
    ----------------------------------------------------------------------------------------

    One System to rule them all, One Code to find them,
    One IDE to bring them all, and to the Framework bind them,
    in the Land of Redmond, where the Windows lie
    ---------------------------------------------------------------------------------
    People call me crazy because i'm jumping out of perfectly fine airplanes.
    ---------------------------------------------------------------------------------
    Code is like a joke: If you have to explain it, it's bad

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width