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

Vincent88 · Sep 2, 2021

Hi, I use sheet of Feb 2022. The dates range consists of Jan to March. Feb 4 is the 1st work day in Feb

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-Jan

28-Jan

29-Jan

30-Jan

31-Jan

1-Feb

2-Feb

3-Feb

4-Feb

5-Feb

6-Feb

7-Feb

8-Feb

9-Feb

10-Feb

11-Feb

12-Feb

13-Feb

14-Feb

15-Feb

16-Feb

17-Feb

18-Feb

19-Feb

20-Feb

21-Feb

22-Feb

23-Feb

24-Feb

25-Feb

26-Feb

27-Feb

28-Feb

1-Mar

2-Mar

3-Mar

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:17 L:0 D:0 E:0 N:0

G

E

4

M Josh

T:17 L:0 D:0 E:0 N:0

E

G

5

C Rossini

T:17 L:0 D:0 E:0 N:0

N

6

J Wcmath

T:17 L:0 D:0 E:0 N:0

D

7

T:17 L:0 D:0 E:0 N:0

D3

8

T:17 L:0 D:0 E:0 N:0

D2

9

T:17 L:0 D:0 E:0 N:0

10

T:17 L:0 D:0 E:0 N:0

D

11

T:17 L:0 D:0 E:0 N:0

VL

D

12

T:17 L:0 D:0 E:0 N:0

D

13

T:17 L:0 D:0 E:0 N:0

D

N

D

14

T:17 L:0 D:0 E:0 N:0

D

202202

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

maabadi · Sep 2, 2021

Sorry try this 3 macro:

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)
Resum1:
N = Lc + 1
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
        If N < M Then GoTo Resum1
        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

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)
Resum1:
N = Lc + 1
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
        If N < M Then GoTo Resum1
        GoTo Resum2
        End If

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
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

VBA Code:

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)
Resum1:
N = Lc + 1
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
        If N < M Then GoTo Resum1
        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,
The normal code is fine but the double click mode shows error.

Vincent88 · Sep 2, 2021

Hi maabadi,
I combine the doubleclick and standard mode as one event. please see if there is any area to make it more neatly. Thanks.

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)
Resum1:
N = Lc + 1
N = Evaluate("=INDEX(" & Cells(1, M).Address & ":" & Cells(1, Lc).Address & ",MATCH(TRUE,COUNTIF(Data!A2: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
        If N < M Then GoTo Resum1
        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

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)
        Select Case Cells(CLng(Ra(i)) + 3, M).Value
               Case "D", "D1", "D2", "D3", "D4", "D5", "G", "K"
        S(CLng(Ra(i)), CLng(Ca(j))) = Cells(CLng(Ra(i)) + 3, M).Value
        End Select
    Next j
Next i

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

Application.DisplayAlerts = True
End Sub

maabadi · Sep 2, 2021

Vincent88 said:
The normal code is fine but the double click mode shows error.

You should add

VBA Code:

On Error Resume Next

After Dim lines such as Normal code.

Also Do same work fir mixed Code and then Test Both

Vincent88 · Sep 6, 2021

Hi maabadi,
How to add two more conditions not to copy the value in a row if
1. any cells NOT (ISEMPTY(CELL))
2. any cells with any interior colors other than RGB(255, 245, 230) (this is the weekend color)
(With image provided, I mean N3 and S3 should have no impact when run the marco.
I also find a function to search for cells with interior-colored but I do not know how to assemble it to your codes.

VBA Code:

Public Function HasColor(rg As Range, color As Long) As Boolean
  If rg.DisplayFormat.Interior.color = color Then
    HasColor = True
  ElseIf VBA.IsNull(rg.DisplayFormat.Interior.colorIndex) Then
    ' The color index is null so there is more than one color in the range
    Dim midrow&
    midrow = rg.Rows.Count \ 2
    If HasColor(rg.Resize(midrow), color) Then
      HasColor = True
    ElseIf HasColor(rg.Resize(rg.Rows.Count - midrow).Offset(midrow), color) Then
      HasColor = True
    End If
  End If
End Function

maabadi · Sep 6, 2021

Rich (BB code):

1. any cells NOT (ISEMPTY(CELL))

At this situation if you change month the you hold filled cell Values. then code cannot add new values to them.
if you want solve it then add that fixed values specific color to change code based on.
I think you give wrong code for yellow color cell. you give me pink color RGB Code.
With formula I write with Green Color at the code change it to your yellow color code.
Also I add Select Case Method with Green Line and ' at the first of that lines. if you want it , I give structure within Code:

VBA Code:

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If Sh.Name = "Data" Then Exit Sub
    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)
Resum1:
    N = Lc + 1
    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
    If N < M Then GoTo Resum1
    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
ReDim Ar(3 To Lr, M + 1 To F)
For i = 3 To Lr
   
    For j = M + 1 To F
        If Range("A" & i).Value <> "" Then 'R = R & " " & i - 3
            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
            'Find Long Value for RGB Color = Red + Green * 256 + Blue * 65536
                If Cells(i, j).Interior.Color = 15136255 Or Cells(i, j).Value <> "" Then
                    Ar(i, j) = Cells(i, j).Value
                Else
     ' if you want Select case add it here or remove ' at next lines and then delete first line after them
'                    Select Case Cells(i, M).Value
'                        Case "D", "D1", "D2", "D3", "D4", "D5", "G", "K"
'                            Ar(i, j) = Cells(i, M).Value
'                    End Select
                    Ar(i, j) = Cells(i, M).Value
                End If
            End If
        Else
            If Cells(i, j).Value <> "" Then Ar(i, j) = Cells(i, j).Value
        End If
    Next j
Next i

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

Application.DisplayAlerts = True
End Sub

Vincent88 · Sep 7, 2021

Hi maabadi,
Before moving further to my latest request, I found the code in post 32 does not work correctly. It fills the holidays' column as well.
However the code using ISHOLWEEKEND function in Post 19 does the job properly.

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

26-Sep

27-Sep

28-Sep

29-Sep

30-Sep

1-Oct

2-Oct

3-Oct

4-Oct

5-Oct

6-Oct

7-Oct

8-Oct

9-Oct

10-Oct

11-Oct

12-Oct

13-Oct

14-Oct

15-Oct

16-Oct

17-Oct

18-Oct

19-Oct

20-Oct

21-Oct

22-Oct

23-Oct

24-Oct

25-Oct

26-Oct

27-Oct

28-Oct

29-Oct

30-Oct

31-Oct

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 K

T:19 L:0 D:20 E:0 N:0

G

4

Jane L

T:19 L:0 D:20 E:0 N:0

D

5

George M

T:19 L:0 D:20 E:0 N:0

K

6

Bebe M

T:19 L:0 D:20 E:0 N:0

D4

7

Apple M

T:19 L:0 D:20 E:0 N:0

D3

8

Kitty S

T:19 L:0 D:0 E:0 N:4

D

N

9

Zita L

T:19 L:0 D:0 E:3 N:0

D3

E

202110

Cells with Data Validation
Cell	Allow	Criteria
A3:A9	List	=HelpAgent
H3:AL9	List	=ShiftcodeNew

VBA Code:

Sub FillNetworkDays22M32()
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)
Resum1:
N = Lc + 1
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
        If N < M Then GoTo Resum1
        GoTo Resum2
        End If

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
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)
    Select Case Cells(CLng(Ra(i)) + 3, M).Value
               Case "D", "D1", "D2", "D3", "D4", "D5", "G", "K"
        S(CLng(Ra(i)), CLng(Ca(j))) = Cells(CLng(Ra(i)) + 3, M).Value
    End Select
    Next j
Next i

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

maabadi · Sep 7, 2021

Vincent88 said:
I found the code in post 32 does not work correctly. It fills the holidays' column as well.

I see Code working Correctly. this code only write the cells belong to month with 1 day within range. here is October. then only cells has in October ranges (here column H and later) Affected. and column C to G (with previous Month Data) not affected here and maintain previous data.

Vincent88 · Sep 9, 2021

maabadi said:
I see Code working Correctly. this code only write the cells belong to month with 1 day within range. here is October. then only cells has in October ranges (here column H and later) Affected. and column C to G (with previous Month Data) not affected here and maintain previous data.

Hi maabadi,
I know it will have no impact in the previous month columns but it can't find which date is holiday of the month. See my screenshot to show you that Feb 9 is holiday but the marco copies the value to that column as well.
Please help.

Copy value from one cell to balance cells in same row

Vincent88

Active Member

Vincent88

Active Member

Excel Facts

maabadi

Well-known Member

Vincent88

Active Member

Attachments

Vincent88

Active Member

maabadi

Well-known Member

Vincent88

Active Member

Attachments

maabadi

Well-known Member

Vincent88

Active Member

maabadi

Well-known Member

Vincent88

Active Member

Attachments

Similar threads

Forum statistics

Share this page

Copy value from one cell to balance cells in same row

Active Member

Active Member

Excel Facts

Well-known Member

Active Member

Attachments

Active Member

Well-known Member

Active Member

Attachments

Well-known Member

Active Member

Well-known Member

Active Member

Attachments

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