Copy value from one cell to balance cells in same row

V

Vincent88

Active Member
Joined
Mar 5, 2021
Messages
382
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
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
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKAL
1MDateAttendance27-Jul28-Jul29-Jul30-Jul31-Jul1-Aug2-Aug3-Aug4-Aug5-Aug6-Aug7-Aug8-Aug9-Aug10-Aug11-Aug12-Aug13-Aug14-Aug15-Aug16-Aug17-Aug18-Aug19-Aug20-Aug21-Aug22-Aug23-Aug24-Aug25-Aug26-Aug27-Aug28-Aug29-Aug30-Aug31-Aug
2DateSummary(5)(4)(3)(2)(1)12345678910111213141516171819202122232425262728293031
3Mary WT:22 L:0 D:1 E:0 N:0GGGGGD
4M JoshT:22 L:0 D:0 E:0 N:0DDDDD
5C RossiniT:22 L:0 D:0 E:0 N:0EEEEE
6J WcmathT:22 L:0 D:0 E:0 N:0D4PMD4D4AL
7T:22 L:0 D:0 E:0 N:0DDVLVLD
8T:22 L:0 D:0 E:0 N:0DDDD
9T:22 L:0 D:0 E:0 N:0DDDD
10T:22 L:0 D:0 E:0 N:0DDDD
11T:22 L:0 D:0 E:0 N:0VLVLDD
12T:22 L:0 D:0 E:0 N:0DDDDD
13T:22 L:0 D:0 E:0 N:0DNDD
14T:22 L:0 D:0 E:0 N:0DDDDD
202108
Cells with Data Validation
CellAllowCriteria
H3:AL14List=ShiftcodeNew
A3:A13List=HelpAgent
A14List=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
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
Try this Formula:
Book1
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAM
1MDateAttendance27-Jul28-Jul29-Jul30-Jul31-Jul1-Aug2-Aug3-Aug4-Aug5-Aug6-Aug7-Aug8-Aug9-Aug10-Aug11-Aug12-Aug13-Aug14-Aug15-Aug16-Aug17-Aug18-Aug19-Aug20-Aug21-Aug22-Aug23-Aug24-Aug25-Aug26-Aug27-Aug28-Aug29-Aug30-Aug31-Aug
2DateSummary-5-4-3-2-112345678910111213141516171819202122232425262728293031
3Mary WT:22 L:0 D:1 E:0 N:0GGGGGDDDDDD  DDDDD  DDDDD  DDDDD  DD
4M JoshT:22 L:0 D:0 E:0 N:0DDDDD                              
5C RossiniT:22 L:0 D:0 E:0 N:0EEEEE                              
6J WcmathT:22 L:0 D:0 E:0 N:0D4PMD4D4AL                              
7T:22 L:0 D:0 E:0 N:0DDVLVLD                              
8T:22 L:0 D:0 E:0 N:0DDDD                              
9T:22 L:0 D:0 E:0 N:0DDDD                              
10T:22 L:0 D:0 E:0 N:0DDDD                              
11T:22 L:0 D:0 E:0 N:0VLVLDD                              
12T:22 L:0 D:0 E:0 N:0DDDDD                              
13T:22 L:0 D:0 E:0 N:0DNDD                              
14T:22 L:0 D:0 E:0 N:0DDDDD                              
15
16
Sheet1
Cell Formulas
RangeFormula
I3:AL14I3=IF((NETWORKDAYS(I$1,I$1)>0)*($A3<>"")*($H3<>""),$H3,"")
 
Upvote 0
Try this:
VBA Code: 
Sub FillNetworkDays()
Dim i As Long, j As Long, M As Long, Lr As Long, F As Long
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 i = 3 To Lr
If Range("A" & i).Value <> "" And Cells(i, M).Value <> "" Then
For j = M + 1 To F
If Application.WorksheetFunction.NetworkDays(Cells(1, j).Value, Cells(1, j).Value) = 1 Then
Cells(i, j).Value = Cells(i, M).Value
Else
Cells(i, j).Value = ""
End If
Next j
End If
Next i
End Sub
 
Upvote 0
Hi maabadi, It seems that your code will copy the value to the holidays as well. I want the value to be pasted to net workdays (excludes those holidays and weekends), that is why I have the function IsHolWeekend at top of the module.
 
Upvote 0
How about:
VBA Code: 
Sub FillNetworkDays()
Dim i As Long, j As Long, M As Long, Lr As Long, F As Long
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 i = 3 To Lr
If Range("A" & i).Value <> "" And Cells(i, M).Value <> "" Then
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) = True Then
Cells(i, j).Value = Cells(i, M).Value
Else
Cells(i, j).Value = ""
End If
Next j
End If
Next i
End Sub
 
Upvote 0
Sorry My fault. Change True to False at previous code.
 
Upvote 0
You can try this also...
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))
    Application.EnableEvents = False
    For vN = 3 To alastRow
        If Not Cells(vN, 1) Is Nothing Then
            For vN2 = acolumnB1.Column To acolumnE1.Column
                If Not IsHolWeekend(Cells(1, vN2)) Then
                    Cells(vN, acolumnB1.Column).Copy
                    Cells(vN, vN2).PasteSpecial
                End If
            Next vN2
        End If
    Next vN
    Application.EnableEvents = True
    Application.CutCopyMode = False

End Sub
 
Upvote 0
maabadi said:
Sorry My fault. Change True to False at previous code.
Click to expand...
Hi maabadi,
The code works but the pasting progress to cells is slow ( pasting cell after cell).
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.
 
Last edited:
Upvote 0
EXCEL MAX said:
You can try this also...
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))
    Application.EnableEvents = False
    For vN = 3 To alastRow
        If Not Cells(vN, 1) Is Nothing Then
            For vN2 = acolumnB1.Column To acolumnE1.Column
                If Not IsHolWeekend(Cells(1, vN2)) Then
                    Cells(vN, acolumnB1.Column).Copy
                    Cells(vN, vN2).PasteSpecial
                End If
            Next vN2
        End If
    Next vN
    Application.EnableEvents = True
    Application.CutCopyMode = False

End Sub
Click to expand...
Hi EXCEL MAX,
Thanks again. The code has error - if row in column A is blank, the code also copying the data. (see image attached)
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.
 

Attachments

  • error copying.png
    error copying.png
    52.2 KB · Views: 7
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question Question
VBA Code to Send Mail to skip blank cells
Replies
1
Views
269
Micron
M
Asbestos_Jen
  • Question Question
Compare multiple parameters of samples to reference values (Excel 2007)
Replies
3
Views
338
Asbestos_Jen
Asbestos_Jen
M
  • Question Question
assigning one of three values to cell to get a score of the row
Replies
1
Views
133
dreid1011
dreid1011
A
  • Solved
hide row if 2 cell of same row is blank
Replies
3
Views
143
Joe4
Joe4
J
  • Question Question
Automatically move cells from one sheet to another based on criteria using VBA
Replies
5
Views
707
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,229
Messages
6,170,881
Members
452,364
Latest member
springate

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top