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 · Aug 29, 2021

Vincent88 said:
The code works but the pasting progress to cells is slow ( pasting cell after cell).

The code need to check each cell at first row to understand it is Networkday or Holiday or Not.

Vincent88 said:
Meantime the code applies to entire range. What will be the code if I want to apply it to a single target cell/row only where I run the module , if needed, manually.

Are you want Worksheet Change Event to when you change data at column A or Column of First day of Month Code runs automatically.

EXCEL MAX · Aug 29, 2021

Yes, it was fault.
Now I better understand your request.
Select name in the column "A" and call "AutoInput9" procedure after that.

This goes to the ThisWorkbook module.

VBA Code:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call KeepTarget
End Sub

This goes to the standard module. This public variable will transfer "Target" through workbook.

VBA Code:

Public vTarget As Range
Sub StartV()
   Set vTarget = ActiveCell
End Sub

And this is modification of your code.

VBA Code:

Sub AutoInput9()

    Dim aRng As Range, aRng1 As Range
    Dim alastRow As Long, alastCol As Long
    Dim aRngCol As Range, aRngRow As Range
    
    Application.ScreenUpdating = False
    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))
    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)
    Dim aRngInput As Range
    Set aRngInput = Range(Cells(3, acolumnB1.Column + 1), _
                    Cells(alastRow, acolumnE1.Column))
    If aRng.Rows.Count > 2 Then
        Set aRng1 = Intersect([vTarget], 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 vTarget.Column = 1 And Not (IsEmpty(vTarget)) Then
            For vN = acolumnB1.Column + 1 To acolumnE1.Column
                If IsHolWeekend(Cells(1, vN)) = False Then
                    Cells(vTarget.Row, vN).Value = _
                    Cells(vTarget.Row, acolumnB1.Column).Value
                End If
            Next
        End If
    End If

End Sub

EXCEL MAX · Aug 29, 2021

Correction...
replace the name of the procedure "StartV" with name "KeepTarget".

maabadi · Aug 30, 2021

Try this Version:

VBA Code:

Sub FillNetworkDays()
Dim i As Long, j As Long, M As Long, Lr As Long, F As Long, C As String, R As String, S As Variant
Dim Ca As Variant, Ra As Variant
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)
For j = M + 1 To F
If Application.WorksheetFunction.NetworkDays(Cells(1, j).Value, Cells(1, j).Value) = 1 And IsHolWeekend(Cells(1, j).Value) = False 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

And if you want Worksheet Change Event Try this:

VBA Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, j As Long, M As Long, Lr As Long, F As Long, C As String, R As String, S As Variant
Dim Ca As Variant, Ra As Variant
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)
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
If Application.WorksheetFunction.NetworkDays(Cells(1, j).Value, Cells(1, j).Value) = 1 And IsHolWeekend(Cells(1, j).Value) = False 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 · Aug 31, 2021

Hi maabadi,
Your code is working much much faster now. However It was my fault from the beginning that instead of copying data from the first date of month, it should be the first workday of the month - like in August, the data in Aug 2 and in Jan next year, the data in Jan 3 should be used to copy. Appreiciate your help.

maabadi · Aug 31, 2021

You're Welcome & Thanks for Follow-up.

Vincent88 · Aug 31, 2021

EXCEL MAX said:
Correction...
replace the name of the procedure "StartV" with name "KeepTarget".

Hi EXCEL MAX,
Your latest code runs cell after cell which is not efficient. Your initial code is much better but needs to modify that if the value in row of column A is empty, the code not applies and the active cell should be the first workday of the month not in column A. Please help.

Vincent88 · Aug 31, 2021

maabadi said:
You're Welcome & Thanks for Follow-up.

Which part of the code should be amended to change from 1st day of month to the first workday ?

maabadi · Aug 31, 2021

For Normal Macro Try this:

VBA Code:

Sub FillNetworkDays()
Dim i As Long, j As Long, M As Long, Lr As Long, F As Long, C As String, R As String, S As Variant
Dim Ca As Variant, Ra As Variant
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

For j = M + 1 To F
If Application.WorksheetFunction.NetworkDays(Cells(1, j).Value, Cells(1, j).Value) = 1 And IsHolWeekend(Cells(1, j).Value) = False 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

And WorkSheet Change Event:

VBA Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, j As Long, M As Long, Lr As Long, F As Long, C As String, R As String, S As Variant
Dim Ca As Variant, Ra As Variant
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)
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, 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
If Application.WorksheetFunction.NetworkDays(Cells(1, j).Value, Cells(1, j).Value) = 1 And IsHolWeekend(Cells(1, j).Value) = False 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 1, 2021

Hi maabadi,
I want to apply the code to DoubleClick event but limit it to the first networkdays cell in row 2 of that column ( if the first networkdays is Jan 4, 2022 in column K, then double click K2 triggers the run)(see image). My code applies to the whole row in the range. How to modify it ?

Meantime If I run the worksheet change event, the error highlights IsHolWeekend .

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
          lastColR = Cells(1, Columns.Count).End(xlToLeft).Column
        
           If Not Intersect(Target, Range(Cells(2, 3), Cells(2, lastColR))) Is Nothing Then              'Apply to Row 2 in Range
            Cancel = True
          Application.DisplayAlerts = False
             FillNetworkDays
          Application.DisplayAlerts = True
          
          End If
    
End Sub

Copy value from one cell to balance cells in same row

Vincent88

Active Member

maabadi

Well-known Member

Excel Facts

EXCEL MAX

Well-known Member

EXCEL MAX

Well-known Member

maabadi

Well-known Member

Vincent88

Active Member

maabadi

Well-known Member

Vincent88

Active Member

Vincent88

Active Member

maabadi

Well-known Member

Vincent88

Active 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

Well-known Member

Well-known Member

Well-known Member

Active Member

Well-known Member

Active Member

Active Member

Well-known Member

Active 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