extract names according to range of dates into different column below each date

[emwaj]

Hey

I have a sheet (named "daily") with a date in each column in row 6. Relevant names are from row 10 and below.

In another sheet (named "general") I have different rows with names, and range of dates. Names are in column B , date "from" is in column F and date "to" is in column G.

I am looking for a macro which would take each name in each row in sheet "general", and put it in each column in sheet "daily" below the relevant date.

For example:
In "general" sheet, Eric is from 1 may 2019 to 6 may 2019. Then in sheet "daily", the name Eric will be in the column below these dates.
The name is written in the first empty row below row 10 (row 10 is the first writable row. if this row is already not empty, then the next name is written below, etc)

If someone knows how to do that, it would be nice!

 

[DanteAmor]

Try the following, only in row 6 of your Daily sheet put the dates in short date format (mm/dd/yyyy)

Sub extract_names()
    Application.ScreenUpdating = False
    Set h1 = Sheets("general")
    Set h2 = Sheets("daily")
    '
    'take each name in each row in sheet "general"
    For i = 2 To h1.Range("B" & Rows.Count).End(xlUp).Row
        w_name = h1.Cells(i, "B").Value
        fec1 = h1.Cells(i, "F").Value
        fec2 = h1.Cells(i, "G").Value
        For j = fec1 To fec2
            Set b = h2.Rows(6).Find(j, lookat:=xlWhole, LookIn:=xlValues)
            If Not b Is Nothing Then
                u2 = h2.Cells(Rows.Count, b.Column).End(xlUp).Row + 1
                If u2 < 10 Then u2 = 10
                h2.Cells(u2, b.Column).Value = w_name
            End If
        Next
    Next
    Application.ScreenUpdating = True
    h2.Select
    MsgBox "End"
End Sub

Let me know if you have any question

 

[emwaj]

Try the following, only in row 6 of your Daily sheet put the dates in short date format (mm/dd/yyyy)

Sub extract_names()
    Application.ScreenUpdating = False
    Set h1 = Sheets("general")
    Set h2 = Sheets("daily")
    '
    'take each name in each row in sheet "general"
    For i = 2 To h1.Range("B" & Rows.Count).End(xlUp).Row
        w_name = h1.Cells(i, "B").Value
        fec1 = h1.Cells(i, "F").Value
        fec2 = h1.Cells(i, "G").Value
        For j = fec1 To fec2
            Set b = h2.Rows(6).Find(j, lookat:=xlWhole, LookIn:=xlValues)
            If Not b Is Nothing Then
                u2 = h2.Cells(Rows.Count, b.Column).End(xlUp).Row + 1
                If u2 < 10 Then u2 = 10
                h2.Cells(u2, b.Column).Value = w_name
            End If
        Next
    Next
    Application.ScreenUpdating = True
    h2.Select
    MsgBox "End"
End Sub

Let me know if you have any question

Thank you for your quick answer!
It doesn't work

I put the macro in General sheet, under Private Sub Worksheet_Change(ByVal Target As Range) because I would like it would work automatically only after any changes in dates from column F & G (from row 3 down).


Private Sub Worksheet_Change(ByVal Target As Range)
'extract_names



Application.ScreenUpdating = False


Set h1 = Sheets("general")
Set h2 = Sheets("daily")
'
'take each name in each row in sheet "general"
For i = 3 To h1.Range("B" & Rows.Count).End(xlUp).Row
w_name = h1.Cells(i, "B").Value
fec1 = h1.Cells(i, "F").Value
fec2 = h1.Cells(i, "G").Value
For j = fec1 To fec2
Set b = h2.Rows(6).Find(j, lookat:=xlWhole, LookIn:=xlValues)
If Not b Is Nothing Then
u2 = h2.Cells(Rows.Count, b.Column).End(xlUp).Row + 1
If u2 < 10 Then u2 = 10
h2.Cells(u2, b.Column).Value = w_name
End If
Next
Next
Application.ScreenUpdating = True
h2.Select
MsgBox "End"

End Sub

 

[DanteAmor]

But first test the macro in a module.
It is important that your dates are in row 6.
If you have problems, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[emwaj]

But first test the macro in a module.It is important that your dates are in row 6.If you have problems, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

It's work, thank you!!

 

[DanteAmor]

I append the code for the Change event, when you change the date in E or F the macro will update the Daily sheet

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("F:G")) Is Nothing Then
        If Target.Count > 1 Then Exit Sub
        Application.ScreenUpdating = False
        Set h1 = Sheets("general")
        Set h2 = Sheets("daily")
        '
        'take the name whe updated date "general"
        i = Target.Row
        w_name = h1.Cells(i, "B").Value
        fec1 = h1.Cells(i, "F").Value
        fec2 = h1.Cells(i, "G").Value
        If fec1 = "" Or fec2 = "" Then Exit Sub
        For j = fec1 To fec2
            Set b = h2.Rows(6).Find(j, lookat:=xlWhole, LookIn:=xlValues)
            If Not b Is Nothing Then
                u2 = h2.Cells(Rows.Count, b.Column).End(xlUp).Row + 1
                If u2 < 10 Then u2 = 10
                h2.Cells(u2, b.Column).Value = w_name
            End If
        Next
        Application.ScreenUpdating = True
    End If
End Sub

 

[emwaj]

I append the code for the Change event, when you change the date in E or F the macro will update the Daily sheet

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("F:G")) Is Nothing Then
        If Target.Count > 1 Then Exit Sub
        Application.ScreenUpdating = False
        Set h1 = Sheets("general")
        Set h2 = Sheets("daily")
        '
        'take the name whe updated date "general"
        i = Target.Row
        w_name = h1.Cells(i, "B").Value
        fec1 = h1.Cells(i, "F").Value
        fec2 = h1.Cells(i, "G").Value
        If fec1 = "" Or fec2 = "" Then Exit Sub
        For j = fec1 To fec2
            Set b = h2.Rows(6).Find(j, lookat:=xlWhole, LookIn:=xlValues)
            If Not b Is Nothing Then
                u2 = h2.Cells(Rows.Count, b.Column).End(xlUp).Row + 1
                If u2 < 10 Then u2 = 10
                h2.Cells(u2, b.Column).Value = w_name
            End If
        Next
        Application.ScreenUpdating = True
    End If
End Sub

thank you so much!!!!

 

[DanteAmor]

I'm glad to help you