Copy value from one cell to balance cells in same row

Vincent88 · Aug 29, 2021

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

D

4

M Josh

T:22 L:0 D:0 E:0 N:0

D

5

C Rossini

T:22 L:0 D:0 E:0 N:0

E

6

J Wcmath

T:22 L:0 D:0 E:0 N:0

D4

PM

D4

AL

7

T:22 L:0 D:0 E:0 N:0

D

VL

D

8

T:22 L:0 D:0 E:0 N:0

D

9

T:22 L:0 D:0 E:0 N:0

D

10

T:22 L:0 D:0 E:0 N:0

D

11

T:22 L:0 D:0 E:0 N:0

VL

D

12

T:22 L:0 D:0 E:0 N:0

D

13

T:22 L:0 D:0 E:0 N:0

D

N

D

14

T:22 L:0 D:0 E:0 N:0

D

202108

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

Code:

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 · Sep 1, 2021

Are your date is in row 2 or row 1 ?

VBA Code:

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
        Select Case Sh.Name
                     Case "Data"
              Exit Sub
                     Case Else
              End Select
            
          Dim lastColR As Long, Lr&, M&, F&
          lastColR = Cells(1, Columns.Count).End(xlToLeft).Column
          Lr = Range("A" & Rows.Count).End(xlUp).Row
        M = Application.Match(CLng(DateSerial(Year(Range("C1").Value), Month(Range("C1").Value) + 1, 0)) + 1, Rows(1), 0)
        F = Application.Match(CLng(DateSerial(Year(Cells(1, M).Value), Month(Cells(1, M).Value) + 1, 0)), Rows(1), 0)
Resum2:
        If Application.WorksheetFunction.NetworkDays(Cells(1, M).Value, Cells(1, M).Value) = 1 And IsHolWeekend(Cells(1, M).Value) = False Then
        Else
        M = M + 1
        GoTo Resum2
        End If
        
           If Intersect(Target, Range(Cells(2, M), Cells(2, M))) Is Nothing Then Exit Sub             'Apply to Row 2 in Range
            Cancel = True
          Application.DisplayAlerts = False
             FillNetworkDays
          Application.DisplayAlerts = True
     
    
End Sub

Vincent88 · Sep 1, 2021

maabadi said:

Are your date is in row 2 or row 1 ?

VBA Code:

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
        Select Case Sh.Name
                     Case "Data"
              Exit Sub
                     Case Else
              End Select
            
          Dim lastColR As Long, Lr&, M&, F&
          lastColR = Cells(1, Columns.Count).End(xlToLeft).Column
          Lr = Range("A" & Rows.Count).End(xlUp).Row
        M = Application.Match(CLng(DateSerial(Year(Range("C1").Value), Month(Range("C1").Value) + 1, 0)) + 1, Rows(1), 0)
        F = Application.Match(CLng(DateSerial(Year(Cells(1, M).Value), Month(Cells(1, M).Value) + 1, 0)), Rows(1), 0)
Resum2:
        If Application.WorksheetFunction.NetworkDays(Cells(1, M).Value, Cells(1, M).Value) = 1 And IsHolWeekend(Cells(1, M).Value) = False Then
        Else
        M = M + 1
        GoTo Resum2
        End If
        
           If Intersect(Target, Range(Cells(2, M), Cells(2, M))) Is Nothing Then Exit Sub             'Apply to Row 2 in Range
            Cancel = True
          Application.DisplayAlerts = False
             FillNetworkDays
          Application.DisplayAlerts = True
     
    
End Sub

maabadi said:

Are your date is in row 2 or row 1 ?

VBA Code:

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
        Select Case Sh.Name
                     Case "Data"
              Exit Sub
                     Case Else
              End Select
            
          Dim lastColR As Long, Lr&, M&, F&
          lastColR = Cells(1, Columns.Count).End(xlToLeft).Column
          Lr = Range("A" & Rows.Count).End(xlUp).Row
        M = Application.Match(CLng(DateSerial(Year(Range("C1").Value), Month(Range("C1").Value) + 1, 0)) + 1, Rows(1), 0)
        F = Application.Match(CLng(DateSerial(Year(Cells(1, M).Value), Month(Cells(1, M).Value) + 1, 0)), Rows(1), 0)
Resum2:
        If Application.WorksheetFunction.NetworkDays(Cells(1, M).Value, Cells(1, M).Value) = 1 And IsHolWeekend(Cells(1, M).Value) = False Then
        Else
        M = M + 1
        GoTo Resum2
        End If
        
           If Intersect(Target, Range(Cells(2, M), Cells(2, M))) Is Nothing Then Exit Sub             'Apply to Row 2 in Range
            Cancel = True
          Application.DisplayAlerts = False
             FillNetworkDays
          Application.DisplayAlerts = True
     
    
End Sub

The dates are in row 1 but I apply double click to row 2.

maabadi · Sep 1, 2021

Try to code at Post #21

Vincent88 · Sep 1, 2021

maabadi said:
Try to code at Post #21

Hi maabadi,
It seems that it does not find IsHolidayWeekend function !

maabadi · Sep 1, 2021

Are you add IsHolWeekend posted by you at first post, after this code at same module?

Vincent88 · Sep 2, 2021

maabadi said:
Are you add IsHolWeekend posted by you at first post, after this code at same module?

Yes, I did. It seems that under worksheet events not able to recognize this function ?

Vincent88 · Sep 2, 2021

Vincent88 said:
Yes, I did. It seems that under worksheet events not able to recognize this function ?

I know where my fault. Thanks.

maabadi · Sep 2, 2021

Another Option without need to IsHolWeekend Function
Try this as Workbook Change Event :

VBA Code:

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
          If Sh.Name = "Data" Then Exit Sub
          Dim Lc&, Lr&, Lr2&, M&, F&, N&
          Lr = Range("A" & Rows.Count).End(xlUp).Row
          Lc = Cells(1, Columns.Count).End(xlToLeft).Column
          Lr2 = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
        M = Application.Match(CLng(DateSerial(Year(Range("C1").Value), Month(Range("C1").Value) + 1, 0)) + 1, Rows(1), 0)
        N = Evaluate("=INDEX(" & Cells(1, M).Address & ":" & Cells(1, Lc).Address & ",MATCH(TRUE,COUNTIF(Data!A1:A" & Lr2 & "," & Cells(1, M).Address & ":" & Cells(1, Lc).Address & ")>0,0))")
        N = Application.Match(N, Rows(1), 0)
Resum2:
        If Application.WorksheetFunction.NetworkDays(Cells(1, M).Value, Cells(1, M).Value) = 1 And N <> M Then
        Else
        M = M + 1
        GoTo Resum2
        End If
        F = Application.Match(CLng(DateSerial(Year(Cells(1, M).Value), Month(Cells(1, M).Value) + 1, 0)), Rows(1), 0)
           If Intersect(Target, Range(Cells(2, M), Cells(2, M))) Is Nothing Then Exit Sub             'Apply to Row 2 in Range
            Cancel = True
          Application.DisplayAlerts = False
             FillNetworkDays
          Application.DisplayAlerts = True
 End Sub

And This as FillNetworkDays as Normal Macro:

VBA Code:

Sub FillNetworkDays()
On Error Resume Next
Dim i&, j&, C As String, R As String, S As Variant, Ca As Variant, Ra As Variant
Dim Lc&, Lr&, Lr2&, M&, F&, N&
Lr = Range("A" & Rows.Count).End(xlUp).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
Lr2 = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
M = Application.Match(CLng(DateSerial(Year(Range("C1").Value), Month(Range("C1").Value) + 1, 0)) + 1, Rows(1), 0)
N = Evaluate("=INDEX(" & Cells(1, M).Address & ":" & Cells(1, Lc).Address & ",MATCH(TRUE,COUNTIF(Data!A1:A" & Lr2 & "," & Cells(1, M).Address & ":" & Cells(1, Lc).Address & ")>0,0))")
N = Application.Match(N, Rows(1), 0)
F = Application.Match(CLng(DateSerial(Year(Cells(1, M).Value), Month(Cells(1, M).Value) + 1, 0)), Rows(1), 0)
Resum2:
        If Application.WorksheetFunction.NetworkDays(Cells(1, M).Value, Cells(1, M).Value) = 1 And N <> M Then
        Else
        M = M + 1
        GoTo Resum2
        End If
Resum3:


For j = M + 1 To F
N = 0
N = Application.Match(Cells(1, j).Value, Sheets("Data").Range("A1:A" & Lr2), 0)
If Application.WorksheetFunction.NetworkDays(Cells(1, j).Value, Cells(1, j).Value) = 1 And N = 0 Then C = C & " " & j - M - 1
Next j
For i = 3 To Lr
If Range("A" & i).Value <> "" Then R = R & " " & i - 3
Next i
Ra = Split(Right(R, Len(R) - 1))
Ca = Split(Right(C, Len(C) - 1))
ReDim S(Lr - 3, F - M - 1)
For i = LBound(Ra) To UBound(Ra)
    For j = LBound(Ca) To UBound(Ca)
        S(CLng(Ra(i)), CLng(Ca(j))) = Cells(CLng(Ra(i)) + 3, M).Value
    Next j
Next i

Cells(3, M + 1).Resize(Lr - 2, F - M).Value = S
End Sub

Or Only Use this as Worksheet Change Event:

Excel Formula:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, j&, C As String, R As String, S As Variant, Ca As Variant, Ra As Variant
Dim Lc&, Lr&, Lr2&, M&, F&, N&
Lr = Range("A" & Rows.Count).End(xlUp).Row
Lc = Cells(1, Columns.Count).End(xlToLeft).Column
Lr2 = Sheets("Data").Range("A" & Rows.Count).End(xlUp).Row
M = Application.Match(CLng(DateSerial(Year(Range("C1").Value), Month(Range("C1").Value) + 1, 0)) + 1, Rows(1), 0)
N = Evaluate("=INDEX(" & Cells(1, M).Address & ":" & Cells(1, Lc).Address & ",MATCH(TRUE,COUNTIF(Data!A1:A" & Lr2 & "," & Cells(1, M).Address & ":" & Cells(1, Lc).Address & ")>0,0))")
N = Application.Match(N, Rows(1), 0)
Resum2:
        If Application.WorksheetFunction.NetworkDays(Cells(1, M).Value, Cells(1, M).Value) = 1 And N <> M Then
        Else
        M = M + 1
        GoTo Resum2
        End If
If Intersect(Target, Union(Range("A3:A" & Lr), Range(Cells(3, M), Cells(Lr, M)))) Is Nothing Then Exit Sub
F = Application.Match(CLng(DateSerial(Year(Cells(1, M).Value), Month(Cells(1, M).Value) + 1, 0)), Rows(1), 0)
For j = M + 1 To F
N = 0
N = Application.Match(Cells(1, j).Value, Sheets("Data").Range("A1:A" & Lr2), 0)
If Application.WorksheetFunction.NetworkDays(Cells(1, j).Value, Cells(1, j).Value) = 1 And N = 0 Then C = C & " " & j - M - 1
Next j
i = Target.Row
If Range("A" & i).Value <> "" Then R = R & " " & i - 3

Ra = Split(Right(R, Len(R) - 1))
Ca = Split(Right(C, Len(C) - 1))
ReDim S(F - M - 1)
    For j = LBound(Ca) To UBound(Ca)
        S(CLng(Ca(j))) = Cells(Target.Row, M).Value
    Next j
Range(Cells(Target.Row, M + 1), Cells(Target.Row, F)).Value = S

End Sub

Vincent88 · Sep 2, 2021

Hi maabadi,
I tried normal code but it does not work and it removes those input in the 1st networkday column !

maabadi · Sep 2, 2021

What is the first date you used as Networkdays?
I test it with august-2021 and it copied data from 2-aug to other cells.

Copy value from one cell to balance cells in same row

Vincent88

Active Member

maabadi

Well-known Member

Excel Facts

Vincent88

Active Member

maabadi

Well-known Member

Vincent88

Active Member

Attachments

maabadi

Well-known Member

Vincent88

Active Member

Vincent88

Active Member

maabadi

Well-known Member

Vincent88

Active Member

maabadi

Well-known Member

Similar threads

Forum statistics

Share this page

Copy value from one cell to balance cells in same row

Active Member

Well-known Member

Excel Facts

Active Member

Well-known Member

Active Member

Attachments

Well-known Member

Active Member

Active Member

Well-known Member

Active Member

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock