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
 
Sort by date Sort by votes
Are you sure you have 9 Feb at column A of Data worksheet?
Please upload data at column A of Worksheet Data.
 
Upvote 0

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
maabadi said:
Are you sure you have 9 Feb at column A of Data worksheet?
Please upload data at column A of Worksheet Data.
Click to expand...
I also show the code to find the holidays in the range for your review.

AgentProposal_Roster0728_0829.xlsm
ABCDEFGHIJKLMNOP
2Friday, January 01, 2021D09:00 - 18:00Cat GBady B11Bady B
3Friday, February 12, 2021D409:30 - 18:30Mary KCat G12Cat G
4Saturday, February 13, 2021E15:00 - 23:00John GJack S13Jack S
5Monday, February 15, 2021G07:30 - 16:30Ken CJohn G14John G
6Friday, April 02, 2021N23:00 - 07:30Zita VKen C15Ken C
7Saturday, April 03, 2021OOffLarry QLarry Q16Larry Q
8Monday, April 05, 2021AMAM not availableMandy HMandy H17Mandy H
9Saturday, May 01, 2021PMPM not availableWarus OMary K18Mary K
10Wednesday, May 19, 2021SLSick LeaveJack SNacy L19Nacy L
11Monday, June 14, 2021ALAnnual LeaveNacy LPeter B110Peter B
12Thursday, July 01, 2021COVInjectionPeter BWarus O111Warus O
13Wednesday, September 22, 2021Bady BZita V112Zita V
14Friday, October 01, 2021#N/A113 
15Thursday, October 14, 2021#N/A114 
16Wednesday, November 03, 2021#N/A115 
17Saturday, December 25, 2021#N/A116 
18Monday, December 27, 2021#N/A117 
19Saturday, January 01, 2022#N/A118 
20Monday, January 03, 2022#N/A119 
21Tuesday, February 01, 2022#N/A120 
22Wednesday, February 02, 2022#N/A121 
23Thursday, February 03, 2022#N/A122 
24Wednesday, February 09, 2022#N/A123 
25Tuesday, April 05, 2022#N/A124 
26Friday, April 15, 2022#N/A125 
27Saturday, April 16, 2022#N/A126 
28Monday, April 18, 2022#N/A127 
29Monday, May 02, 2022#N/A128 
30Monday, May 09, 2022#N/A129 
31Friday, June 03, 2022
32Friday, July 01, 2022
33Monday, September 12, 2022
34Saturday, October 01, 2022
35Tuesday, October 04, 2022
36Monday, December 26, 2022
37Tuesday, December 27, 2022
38Sunday, January 01, 2023
Data
Cell Formulas
RangeFormula
M2:M30M2=INDEX([Agent],MATCH(ROWS($L$2:L2),COUNTIF([Agent],"<="&[Agent]),0))
N2:N30N2=IF(ISNUMBER(SEARCH(CELL("contents"),[SortedAgent])),1,"")
O2:O30O2=IF(N2=1,COUNTIF($N$2:N2,1),"")
P2:P30P2=IFERROR(INDEX([SortedAgent],MATCH(ROWS($P$2:P2),[Frequency],0)),"")
Press CTRL+SHIFT+ENTER to enter array formulas.
Named Ranges
NameRefers ToCells
'202108'!HelpAgent=OFFSET(Data!$P$2,,,COUNTIF(Table1[FinalList],"?*"))P2:P30
'202109'!HelpAgent=OFFSET(Data!$P$2,,,COUNTIF(Table1[FinalList],"?*"))P2:P30
'202110'!HelpAgent=OFFSET(Data!$P$2,,,COUNTIF(Table1[FinalList],"?*"))P2:P30
'202111'!HelpAgent=OFFSET(Data!$P$2,,,COUNTIF(Table1[FinalList],"?*"))P2:P30
'202112'!HelpAgent=OFFSET(Data!$P$2,,,COUNTIF(Table1[FinalList],"?*"))P2:P30
'202201'!HelpAgent=OFFSET(Data!$P$2,,,COUNTIF(Table1[FinalList],"?*"))P2:P30
'202202'!HelpAgent=OFFSET(Data!$P$2,,,COUNTIF(Table1[FinalList],"?*"))P2:P30
'202203'!HelpAgent=OFFSET(Data!$P$2,,,COUNTIF(Table1[FinalList],"?*"))P2:P30
HelpAgent=OFFSET(Data!$P$2,,,COUNTIF(Table1[FinalList],"?*"))P2:P30
Cells with Data Validation
CellAllowCriteria
O2:O30Any value
L2:L30Custom=COUNTIF($L:$L,L2)=1

VBA Code: 
Public Function IsHoliday14(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) Then
               IsHoliday14 = True
               Exit Function
            Else
               IsHoliday14 = False
            End If
        Next vR1
     End With
    
End Function


Sub FindHoliday14()

    Dim vRng As Range
    Dim vLastRow As Long
    Dim vRngCol As Range
    
    With ThisWorkbook.ActiveSheet
        vLastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        Set vRng = Range("C1", Range("AL" & vLastRow))
        For Each vRngCol In vRng.Columns
            If IsHoliday14(vRngCol.Cells(1)) = True Then
                  vRngCol.Font.Color = vbRed
            Else
                  vRngCol.Font.Color = vbBlack
            End If
        Next vRngCol
    End With
 
Upvote 0
I don't Know why Match function don't find 9-Feb at Column A. Then I change it to Countif Function. Try this:
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&
    With Sh
    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 = Application.CountIf(Sheets("Data").Range("A1:A" & Lr2), .Cells(1, j).Value)
            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
End With
Application.DisplayAlerts = True
End Sub
 
Upvote 0
Hi maabadi,
The new code works now.
One more favorite to ask. The current code will make blank cells for those weekends and holidays column when copying. If I want to them remains as is -meaning if there is value then value unchanged while those are blank remain blank. See image attached in Feb 6 and Feb 9 columns.
 

Attachments

  • onemore.png
    onemore.png
    29.5 KB · Views: 6
Upvote 0
Try this:
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&
    With Sh
    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 = Application.CountIf(Sheets("Data").Range("A1:A" & Lr2), .Cells(1, j).Value)
            If Application.WorksheetFunction.NetworkDays(.Cells(1, j).Value, .Cells(1, j).Value) = 1 And N = 0 Then
            'only add values to White Background & Empty Cells
                If .Cells(i, j).Interior.Color = 16777215 And .Cells(i, j).Value = "" Then
                    Ar(i, j) = .Cells(i, M).Value
       ' 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
                Else
                    Ar(i, j) = .Cells(i, j).Value
                End If
                Else
                If .Cells(i, j).Value <> "" Then Ar(i, j) = .Cells(i, j).Value
            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
End With
Application.DisplayAlerts = True
End Sub
 
Upvote 0
Solution
maabadi said:
You're Welcome &Thanks For Follow-up.
Click to expand...
Hi maabadi,
Can I add one more conditions to copy the data :
If .Cells(i, j).Interior.Color = 16777215 And .Cells(i, j).Value = "" And .Cells.(i, j).Interior.Pattern = xlNone then
 
Upvote 0
Hi maabadi,
I try to adopt this script concept
If .Cells(i, j).Interior.Color = 16777215 And .Cells(i, j).Value = "" And .Cells(i, j).Interior.Pattern = xlNone Then to another double click function but it not works. Please review and advise.
What I need is to copy the target cell value to its adjacent 4 cells if those adjacent cells are empty, non patterned and non high-lighted regardless of weekdays, weekends and holidays. Any of those cells that meets the criteria will paste the value to it otherwise not.


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/OFF FORMATTING CELLS TO PATTERN
'https://www.mrexcel.com/board/threads/error-before-double-click-function.1185307/#post-5774690
'Post 4 Joe4

    On Error Resume Next

Dim lrow As Long
Dim Lcol As Long
Dim rngArea As Range
Dim wkend As Boolean
Dim pat As Double
Dim col4 As Long

lrow = Range("A" & Rows.Count).End(xlUp).Row
Lcol = Cells(1, Columns.Count).End(xlToLeft).Column

Set rngArea = Range(Cells(3, 8), Cells(lrow, Lcol))

Debug.Print rngArea.Address

If Not Intersect(Target, rngArea) Is Nothing Then
    Cancel = True
    If Not IsEmpty(Target.Value) Then
       [B] For col4 = 1 To 4
           If Cells(, col4).Interior.Color = 16777215 And Cells(, col4).Value = "" And Cells(, col4).Interior.Pattern = xlNone Then
                    
                 Cells(, col4).Value = Target.Value
           Else
           If Cells(, col4).Value <> "" Then Cells(, col4).Value
           End If
        Next col4[/B]
          
        Else
    '   Get interior pattern number
        pat = Target.Interior.Pattern
        
    '   Check to see if weekend
        wkend = IsWeekend(Cells(1, Target.Column))
        
    '   Check to see if it has no lined pattern at all
        'pattern -4142 = xlPatternNone  and pattern 1 = xlPatternSolid
        If (pat = -4142) Or (pat = 1) Then
            Target.Interior.Pattern = xlPatternUp               ' or xlPatternLightVertical
            Target.Interior.PatternColor = RGB(166, 166, 166)
        Else
    
    '       Check to see if it has lined pattern
            'If pat = -4162 Then               'pattern -4162 = xlPatternUp
            If Not IsEmpty(pat) Then           'applicable to any pattern
    '           Check to see if weekend
                If wkend = True Then
                    Target.Interior.Pattern = xlNone
                    Target.Interior.Color = RGB(255, 245, 230)
                Else
                    Target.Interior.Pattern = xlNone
                End If
            End If
        End If
          
    End If
End If
 
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,230
Messages
6,170,883
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