Fairly simple (I think) VBA code with input boxes, dates and copying/naming ranges

[StuFromSaturday]

Evening all, I wonder if someone could help me out with some VBA?

I have a situation that crops up all the time whereby I have a named range comprised of anything between 4 and 25 rows, and between 1 and unlimited columns (though usually no more than, say, 10). This range does not always begin in the first row or first column of the sheet. The first cell in the range ALWAYS contains the same string – this is not repeated anywhere else in the range. There is always a date in the first column of the range (though not always on the same number row within the range) in YYYYMMDD format.

Now.

I need to replicate this range, everything copied exactly as it is but with the date decreasing in value by one day each time, to the cell to the right of wherever the current range ends, over and over again to a starting date of the user’s choosing, backwards from that date I mentioned. The dates need to remain in the same format. And at the end, I need each of the replicated ranges, as well as the original, to be named as per the original, i.e. as if the user were to hold down CTRL and highlight them all individually where the start string occurs, and name the multiple selections with one range name.

This probably sounds a lot more confusing than it looks to me – however my VBA is appallingly (APPALLINGLY) rusty and I need to solve this fairly quickly….I've had a very half-hearted stab but can anyone help please???


Stu

 

[StuFromSaturday]

Not sure if this is the done thing or a liberty but just getting this back up the top.

Moderators I apologise if that's not on, I can't see anything saying otherwise is all.

Thanks.

 

[John_w]

This was fairly tricky, if I've understood you correctly. Before running the code (on a copy of your workbook to be safe) you need to change "NamedRange" in the code to the name of your range.

Public Sub Extend_Named_Range()

    Dim namedRange As Range
    Dim inputString As String
    Dim startDate As Date, endDate As Date
    Dim dateRow As Long
    Dim i As Long
    Dim numCols As Long
    Dim nextDate As Date
    Dim destCell As Range
    
    Set namedRange = Range("NamedRange")        'CHANGE "NamedRange" TO THE NAME OF YOUR RANGE
    
    inputString = InputBox("Enter start date")
    If inputString = "" Then Exit Sub
    startDate = CDate(inputString)
    
    'Find date in first column
    
    With namedRange.Columns(1)
        For i = 1 To .Rows.Count
            If IsDate(.Rows(i).Value) And Len(.Rows(i).Text) = 8 Then
                endDate = DateSerial(Mid(.Rows(i).Text, 1, 4), Mid(.Rows(i).Text, 5, 2), Mid(.Rows(i).Text, 7, 2))
                If Format(endDate, "YYYYMMDD") = .Rows(i).Text Then dateRow = i
            End If
        Next
    End With
    
    'For each date, copy named range to cells to the right
    
    numCols = 0
    For nextDate = endDate - 1 To startDate Step -1
        numCols = numCols + namedRange.Columns.Count
        Set destCell = namedRange.Offset(0, numCols)
        namedRange.Copy destCell
        'Put next date in date cell
        destCell.Item(dateRow, 1).Value = nextDate
    Next
    numCols = numCols + namedRange.Columns.Count
    
    'Extend named range to include copied cells
    
    ActiveWorkbook.Names.Add Name:=namedRange.Name.Name, _
        RefersTo:="=" & namedRange.Parent.Name & "!" & namedRange.Resize(, numCols).Address
        
End Sub

 

[StuFromSaturday]

Hi John, thank you so much for this, I really do appreciate it.

Unfortunately a couple of things - first of all the If IsDate isn't working, though it seems to if I change it to If IsNumeric (is that right?). Secondly, as it copies over it's not stating the backdated dates in YYYYMMDD format, but in DD/MM/YYYY - and finally whilst the entire range is renamed, unfortunately I need each new iteration to be as though the user were holding down CTRL and highlighting, before the collection of all the ranges is named with the one name.

Not sure I'm explaining that as well as I might....does this sound fixable? I could post or send a version of what it should look like if that helps??

Thanks again for your help - apologies for making out it was easier than it was.


Stu

 

[John_w]

Is the date an Excel date (formatted as YYYYMMDD)? If so, then the code should find the date and create the backdated dates in the same format. If not, then say exactly what the date is; is it text in the format YYYYMMDD?

If I've understood you correctly, this amended code highlights each block of copied cells as if the user were holding down Ctrl and selecting each block.

Public Sub Extend_Named_Range()

    Dim namedRange As Range
    Dim inputString As String
    Dim startDate As Date, endDate As Date
    Dim dateRow As Long
    Dim i As Long
    Dim numCols As Long
    Dim nextDate As Date
    Dim destCell As Range
    Dim highlightCells As String
    
    Set namedRange = Range("NamedRange")        'CHANGE "NamedRange" TO THE NAME OF YOUR RANGE
    
    inputString = InputBox("Enter start date")
    If inputString = "" Then Exit Sub
    startDate = CDate(inputString)
    
    'Find date in first column
    
    With namedRange.Columns(1)
        For i = 1 To .Rows.Count
            If IsDate(.Rows(i).Value) And Len(.Rows(i).Text) = 8 Then
                endDate = DateSerial(Mid(.Rows(i).Text, 1, 4), Mid(.Rows(i).Text, 5, 2), Mid(.Rows(i).Text, 7, 2))
                If Format(endDate, "YYYYMMDD") = .Rows(i).Text Then dateRow = i
            End If
        Next
    End With
    
    'For each date, copy named range to cells to the right
    
    highlightCells = namedRange.Address
    numCols = 0
    For nextDate = endDate - 1 To startDate Step -1
        numCols = numCols + namedRange.Columns.Count
        Set destCell = namedRange.Offset(0, numCols)
        namedRange.Copy destCell
        
        'Put next date in date cell
        destCell.Item(dateRow, 1).Value = nextDate
        
        'Highlight each block of cells
        highlightCells = highlightCells & "," & destCell.Resize(, namedRange.Columns.Count).Address
        Range(highlightCells).Select
        MsgBox "Next date"
    Next
    numCols = numCols + namedRange.Columns.Count
    
    'Extend named range to include copied cells
    
    ActiveWorkbook.Names.Add Name:=namedRange.Name.Name, _
        RefersTo:="=" & namedRange.Parent.Name & "!" & namedRange.Resize(, numCols).Address
        
End Sub

The code includes a MsgBox prompt to pause and show the highlighted blocks of cells for each date. You can remove this if you don't need this.

 

[StuFromSaturday]

Ah, fantastic, thank you - that's what I was after.

The date, however, yes, sorry, I wasn't correct on that. Whilst it is representing a date, the figure itself will be in General format, and needs to remain so...sorry. Is that fixable??

Thanks again for this, excellent stuff.

 

[John_w]

Try this version. This time the first For Next loop attempts to identify the date cell, being 8 characters long and a valid date matching YYYYMMDD. You might need to improve this part of the code if you have other 8 character strings which look like a date occurring before the real date.

Public Sub Extend_Named_Range2()

    Dim namedRange As Range
    Dim inputString As String
    Dim startDate As Date, endDate As Date
    Dim dateRow As Long
    Dim i As Long
    Dim numCols As Long
    Dim nextDate As Date
    Dim destCell As Range
    Dim highlightCells As String
    
    Set namedRange = Range("NamedRange")        'CHANGE "NamedRange" TO THE NAME OF YOUR RANGE
    namedRange.Parent.Activate
    
    inputString = InputBox("Enter start date")
    If inputString = "" Then Exit Sub
    startDate = CDate(inputString)
    
    'Find date in first column of named range
    
    With namedRange.Columns(1)
        For i = 1 To .Rows.Count
            With .Rows(i)
                If Len(.Text) = 8 Then
                    If IsDate(DateSerial(Mid(.Text, 1, 4), Mid(.Text, 5, 2), Mid(.Text, 7, 2))) Then
                        endDate = DateSerial(Mid(.Text, 1, 4), Mid(.Text, 5, 2), Mid(.Text, 7, 2))
                        If Format(endDate, "YYYYMMDD") = .Text Then dateRow = i
                    End If
                End If
            End With
        Next
    End With
    
    'For each date, copy named range to cells to the right
    
    highlightCells = namedRange.Address
    numCols = 0
    For nextDate = endDate - 1 To startDate Step -1
        numCols = numCols + namedRange.Columns.Count
        Set destCell = namedRange.Offset(0, numCols)
        namedRange.Copy destCell
        
        'Put next date in date cell
        destCell.Item(dateRow, 1).Value = CStr(Format(nextDate, "YYYYMMDD"))
        
        'Highlight each block of cells
        highlightCells = highlightCells & "," & destCell.Resize(, namedRange.Columns.Count).Address
        Range(highlightCells).Select
        MsgBox "Next date"
    Next
    numCols = numCols + namedRange.Columns.Count
    
    'Extend named range to include copied cells
    
    ActiveWorkbook.Names.Add Name:=namedRange.Name.Name, _
        RefersTo:="=" & namedRange.Parent.Name & "!" & namedRange.Resize(, numCols).Address
        
End Sub

 

[StuFromSaturday]

Thanks, although this doesn't seem to recognize the number at all and doesn't perform any iterations.

No worry, I will stick with the second version and shove something messy in to reformat. Thanks for your time and effort on this, great stuff.