Copy value from one cell to balance cells in same row

[Vincent88]

Hi Guys, I want to copy value of a cell at the 1st day of a month to rest of the workdays that month in the same row if the cell in column A is not empty. Appreciate any help !

AgentProposal_Roster0728_0829.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL
1	MDate	Attendance	27-Jul	28-Jul	29-Jul	30-Jul	31-Jul	1-Aug	2-Aug	3-Aug	4-Aug	5-Aug	6-Aug	7-Aug	8-Aug	9-Aug	10-Aug	11-Aug	12-Aug	13-Aug	14-Aug	15-Aug	16-Aug	17-Aug	18-Aug	19-Aug	20-Aug	21-Aug	22-Aug	23-Aug	24-Aug	25-Aug	26-Aug	27-Aug	28-Aug	29-Aug	30-Aug	31-Aug
2	Date	Summary	(5)	(4)	(3)	(2)	(1)	1	2	3	4	5	6	7	8	9	10	11	12	13	14	15	16	17	18	19	20	21	22	23	24	25	26	27	28	29	30	31
3	Mary W	T:22 L:0 D:1 E:0 N:0	G	G	G	G	G	D
4	M Josh	T:22 L:0 D:0 E:0 N:0	D	D	D	D	D
5	C Rossini	T:22 L:0 D:0 E:0 N:0	E	E	E	E	E
6	J Wcmath	T:22 L:0 D:0 E:0 N:0	D4	PM	D4	D4	AL
7		T:22 L:0 D:0 E:0 N:0	D	D	VL	VL	D
8		T:22 L:0 D:0 E:0 N:0	D	D	D		D
9		T:22 L:0 D:0 E:0 N:0	D	D		D	D
10		T:22 L:0 D:0 E:0 N:0	D		D	D	D
11		T:22 L:0 D:0 E:0 N:0	VL	VL		D	D
12		T:22 L:0 D:0 E:0 N:0	D	D	D	D	D
13		T:22 L:0 D:0 E:0 N:0	D	N		D	D
14		T:22 L:0 D:0 E:0 N:0	D	D	D	D	D
202108

Cells with Data Validation
Cell	Allow	Criteria
H3:AL14	List	=ShiftcodeNew
A3:A13	List	=HelpAgent
A14	List	=HelpAgent

Public Function IsHolWeekend(InputDate As Date) As Boolean

    Dim vLastRow As Long
    Dim vR1 As Range

    With ThisWorkbook.Worksheets("Data")
        vLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each vR1 In .Range("A2:A" & vLastRow)
            If Day(InputDate) = Day(vR1) And _
               Month(InputDate) = Month(vR1) And _
               Year(InputDate) = Year(vR1) Or _
               Weekday(InputDate) = 1 Or _
               Weekday(InputDate) = 7 Then
               IsHolWeekend = True
               Exit Function
            Else
               IsHolWeekend = False
            End If
        Next vR1
     End With
    
End Function


Sub AutoInput9()


Dim aRng As Range, aRng1 As Range
Dim alastRow As Long, alastCol As Long
Dim aRngCol As Range, aRngRow As Range


alastRow = Cells(Rows.Count, "A").End(xlUp).Row
alastCol = Cells(1, Columns.Count).End(xlToLeft).Column


Set aRng = Range(Cells(1, 1), Cells(alastRow & alastCol))
Set aRngRow = Range(Cells(1, 3), Cells(1, alastCol))

    
'Locate the columns of the first and last dates of the month
aDayB1 = CDate(Format(ActiveSheet.Name, "0000-00"))
aDayE1 = DateAdd("m", 1, aDayB1) - 1
Set acolumnB1 = aRngRow.Find(aDayB1, , xlFormulas)
Set acolumnE1 = aRngRow.Find(aDayE1, , xlFormulas)

Debug.Print acolumnB1.Address, acolumnE1.Address

Dim aRngInput As Range
Set aRngInput = Range(Cells(3, acolumnB1.Column + 1), Cells(alastRow, acolumnE1.Column))

Debug.Print aRngInput.Address
 
 If aRng.Rows.Count > 2 Then
        Set aRng1 = Intersect(Target, aRng.Offset(1, 0).Resize(aRng.Rows.Count - 1, aRng.Columns.Count))
    Else
       Set aRng1 = Nothing
    End If

    If Not aRng1 Is Nothing Then
        If Target.Column = 1 And Not (IsEmpty(Target)) Then
           If IsHolWeekend(aRngRow.Cells(1)) = False Then
             Target.Value = Target.aRngInput.Value
             End If
                End If
                  End If

End Sub

 

[maabadi]

Hi. Sometimes 2 AND function don't work at one line. Try to add 3rd condition at the next line and one end if before previous condition end if.

If Cells(, col4).Interior.Color = 16777215 And Cells(, col4).Value = ""   Then
If Cells(, col4).Interior.Pattern = xlNone Then                  
                 Cells(, col4).Value = Target.Value
           Else
           If Cells(, col4).Value <> "" Then Cells(, col4).Value
           End If
       End if