Excel VBA - needs to loop from Start Date to X days and print each date

[mk000]

Hi Excel Pros and forum members... Thank you all in advance!

I am looking for a solution to the following. I have two Sheets in my Book, Sheet1 and Sheet2. Sheet1 contains a list of people with a Begin date and number of days like so...

A

B

C

Name	Begin Date	Days
Mike	1/1/2019	20
Todd	5/15/2019	11
Steve	10/20/2019	90

What i want a vba macro to do is to Loop through each person in column A, and using the start date, make a row for that person in sheet2 starting with the begin date, and however many days in Column C...

Result on Sheet2 would look like...

Name	Date
Mike	1/1/2019
Mike	1/2/2019
Mike	1/3/2019
Mike	... to 20 days
Todd	5/15/2019
Todd	5/16/2019
Todd	5/17/2019
Todd	... to 11 days
Steve	10/20/2019 ... to 90 days....

 

[Trebor76]

Hi mk000,

Try this:

Option Explicit
Sub Macro1()

    Dim lngMyRow As Long
    Dim lngLastRow As Long
    Dim lngPasteRow As Long
    Dim wsSource As Worksheet
    Dim wsDestin As Worksheet
    
    Application.ScreenUpdating = False
    
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDestin = ThisWorkbook.Sheets("Sheet2")
    
    lngLastRow = wsSource.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = 2 To lngLastRow
        lngPasteRow = wsDestin.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        wsDestin.Range("A" & lngPasteRow & ":A" & lngPasteRow + wsSource.Range("C" & lngMyRow) - 1).Value = wsSource.Range("A" & lngMyRow).Value
        With wsDestin.Range("B" & lngPasteRow & ":B" & lngPasteRow + wsSource.Range("C" & lngMyRow) - 1)
            .Formula = "=IF(ROW()=" & lngPasteRow & ",'" & wsSource.Name & "'!B" & lngMyRow & ",B" & lngPasteRow - 1 & "+1)"
            .Value = .Value
        End With
    Next lngMyRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[mk000]

Hi Thanks Robert,

I'm getting a "Run-time error '91' Object variable or With block variable not set on... i think its from this row...

wsDestin.Range("A" & lngPasteRow & ":A" & lngPasteRow + wsSource.Range("C" & lngMyRow) - 1).Value = wsSource.Range("A" & lngMyRow).Value

Here's a better look at the data format and below I also have your code pasted into Developer window...

 

[Trebor76]

I'd say there's nothing in columns A or B on Sheet2. Make sure there's at least headers in columns A and B and try again.

Code works for me.

 

[mk000]

Robert, my apologies. Didnt realize that header was being referenced on Sheet2. You are correct and this work fabulous. Thank you!

 

[Trebor76]

It's not that the headings are being referenced but this line of code...

lngPasteRow = wsDestin.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

...fails if there's nothing on the tab as it's searching for any piece of data to set the variable and doesn't what to do if there isn't anything to find. Though you've solved this by entering the headers, the following will get around the issue via code:

Option Explicit
Sub Macro1()

    Dim lngMyRow As Long
    Dim lngLastRow As Long
    Dim lngPasteRow As Long
    Dim wsSource As Worksheet
    Dim wsDestin As Worksheet
   
    Application.ScreenUpdating = False
   
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsDestin = ThisWorkbook.Sheets("Sheet2")
   
    lngLastRow = wsSource.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngMyRow = 2 To lngLastRow
        On Error Resume Next
            lngPasteRow = wsDestin.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        On Error GoTo 0
        If lngPasteRow = 0 Then lngPasteRow = 2 'Defualt row output if there's no data in column A or B of the 'wsDestin' tab. Change to suit.
        wsDestin.Range("A" & lngPasteRow & ":A" & lngPasteRow + wsSource.Range("C" & lngMyRow) - 1).Value = wsSource.Range("A" & lngMyRow).Value
        With wsDestin.Range("B" & lngPasteRow & ":B" & lngPasteRow + wsSource.Range("C" & lngMyRow) - 1)
            .Formula = "=IF(ROW()=" & lngPasteRow & ",'" & wsSource.Name & "'!B" & lngMyRow & ",B" & lngPasteRow - 1 & "+1)"
            .Value = .Value
        End With
    Next lngMyRow
   
    Application.ScreenUpdating = True

End Sub

this work fabulous. Thank you!

You're welcome

Robert