Combine two routines

B

bdt

Board Regular
Joined
Oct 3, 2024
Messages
53
Office Version
  1. 2019
Platform
  1. Windows
Hi all,
I have a code where I take a range of cells in a column and place them in another sheet in a row, which works fine. In my ignorance I thought I could have another similar piece of code that takes a different range of cells and puts then in the same row as the first piece of code. I didn't appreciate the second code overwrites the first. Is it possible to combine the two codes so that range AI21:AI33 and BM21:BM33 are placed in the same cells in a row on the sheet "OVERTIME". My code is;

'add overtime sunday
With ActiveSheet
WKend = .Range("M2").Value
arr = .Range("AI21:AI33").Value
End With

With Sheets("OVERTIME").Range("A:A")
Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not fndRng Is Nothing Then
fndRng.Offset(, 1).Resize(, UBound(arr)).Value = Application.Transpose(arr)
Else
MsgBox "Sorry, did not find " & WKend
End If

End With

'add absence sunday
With ActiveSheet
WKend = .Range("M2").Value
arr = .Range("BM21:BM33").Value
End With

With Sheets("OVERTIME").Range("A:A")
Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)

If Not fndRng Is Nothing Then
fndRng.Offset(, 1).Resize(, UBound(arr)).Value = Application.Transpose(arr)
Else
MsgBox "Sorry, did not find " & WKend
End If
End With

Many thanks again
 
Sort by date Sort by votes
If I re-start from scratch ignoring everything in this thread except post #20 and the picture from post #11,
this is what I come up with
VBA Code: 
Sub Button3_Click()
    
    Dim firstDate As Date
    Dim lastrow As Long
    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim i As Long
    Dim fndRng As Range

firstDate = ActiveSheet.Range("M2").Value

With Sheets("OVERTIME")
    ' determine where the week of dates starts
    lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
    
    Set fndRng = .Range("A5:A" & lastrow).Find( _
                        What:=Format(firstDate, "dd/mm/yy"), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
    
    If fndRng Is Nothing Then
        MsgBox "Sorry, did not find " & firstDate & vbLf & _
               "Will now exit this sub"
        Exit Sub
    End If
End With

With ActiveSheet
'-----SUNDAY-----
'add overtime and absence sunday
    arr1 = .Range("AI21:AI32").Value
    arr2 = .Range("CY21:CY32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(0, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
    
'-----MONDAY-----
'add overtime and absence monday
    arr1 = .Range("AK21:AK32").Value
    arr2 = .Range("DA21:DA32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(1, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
    
'-----TUESDAY-----
'add overtime and absence tuesday
    arr1 = .Range("AM21:AM32").Value
    arr2 = .Range("DC21:DC32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(2, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
    
'-----WEDNESDAY-----
'add overtime and absence wednesday
    arr1 = .Range("AO21:AO32").Value
    arr2 = .Range("DE21:DE32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(3, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----THURSDAY-----
'add overtime and absence thursday
    arr1 = .Range("AQ21:AQ32").Value
    arr2 = .Range("DG21:DG32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(4, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----FRIDAY-----
'add overtime and absence friday
    arr1 = .Range("AS21:AS32").Value
    arr2 = .Range("DI21:DI32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(5, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----SATURDAY-----
'add overtime saturday no absence
    arr1 = .Range("AU21:AU32").Value
    ' write to sheet and clear array
    fndRng.Offset(6, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing

End With

End Sub
 
  • Like
Reactions: bdt
Upvote 0

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
NoSparks said:
If I re-start from scratch ignoring everything in this thread except post #20 and the picture from post #11,
this is what I come up with
VBA Code: 
Sub Button3_Click()
   
    Dim firstDate As Date
    Dim lastrow As Long
    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim i As Long
    Dim fndRng As Range

firstDate = ActiveSheet.Range("M2").Value

With Sheets("OVERTIME")
    ' determine where the week of dates starts
    lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
   
    Set fndRng = .Range("A5:A" & lastrow).Find( _
                        What:=Format(firstDate, "dd/mm/yy"), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)
   
    If fndRng Is Nothing Then
        MsgBox "Sorry, did not find " & firstDate & vbLf & _
               "Will now exit this sub"
        Exit Sub
    End If
End With

With ActiveSheet
'-----SUNDAY-----
'add overtime and absence sunday
    arr1 = .Range("AI21:AI32").Value
    arr2 = .Range("CY21:CY32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(0, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
   
'-----MONDAY-----
'add overtime and absence monday
    arr1 = .Range("AK21:AK32").Value
    arr2 = .Range("DA21:DA32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(1, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
   
'-----TUESDAY-----
'add overtime and absence tuesday
    arr1 = .Range("AM21:AM32").Value
    arr2 = .Range("DC21:DC32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(2, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
   
'-----WEDNESDAY-----
'add overtime and absence wednesday
    arr1 = .Range("AO21:AO32").Value
    arr2 = .Range("DE21:DE32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(3, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----THURSDAY-----
'add overtime and absence thursday
    arr1 = .Range("AQ21:AQ32").Value
    arr2 = .Range("DG21:DG32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(4, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----FRIDAY-----
'add overtime and absence friday
    arr1 = .Range("AS21:AS32").Value
    arr2 = .Range("DI21:DI32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    fndRng.Offset(5, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----SATURDAY-----
'add overtime saturday no absence
    arr1 = .Range("AU21:AU32").Value
    ' write to sheet and clear array
    fndRng.Offset(6, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing

End With

End Sub
Click to expand...
Thanks NoSparks. Wasn’t expecting you to rewrite the whole code. Will have a look this evening when I get home.
 
Upvote 0
bdt said:
for clarification, arr1 and arr2 have to combine to go into the same row and same columns in "OVERTIME", where arr1 is a number and arr2 is the letter "A".
I have the code below, which does combine the two ranges, but into an existing row in "OVERTIME". With my very limited knowledge of VBA I have no idea how to make this work for my code posted a few minutes ago.

VBA Code: 
Sub Button3_Click()

   
    Dim WKend As Date
    Dim rng1 As Range, rng2 As Range
    Dim fndRng As Range, cel As Range
    Dim i As Long
   
'add overtime and absence sunday
With ActiveSheet
    WKend = .Range("M2").Value
    Set rng1 = .Range("AI21:AI32")
    Set rng2 = .Range("CY21:CY32")
End With

With Sheets("OVERTIME").Range("A:A")
    ' find date
    Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

    If Not fndRng Is Nothing Then   'if found
        i = 1
        For Each cel In rng1
            fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
        i = 1
        For Each cel In rng2
            If cel.Value = "A" Then fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
    Else                            'if not found
        MsgBox "Sorry, did not find " & WKend
    End If
End With


'add overtime and absence monday
With ActiveSheet
    WKend = .Range("AC2").Value
    Set rng1 = .Range("AK21:AK32")
    Set rng2 = .Range("DA21:DA32")
End With

With Sheets("OVERTIME").Range("A:A")
    ' find date
    Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

    If Not fndRng Is Nothing Then   'if found
        i = 1
        For Each cel In rng1
            fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
        i = 1
        For Each cel In rng2
            If cel.Value = "A" Then fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
    Else                            'if not found
        MsgBox "Sorry, did not find " & WKend
    End If
End With


'add overtime and absence tuesday
With ActiveSheet
    WKend = .Range("AS2").Value
    Set rng1 = .Range("AM21:AM32")
    Set rng2 = .Range("DC21:DC32")
End With

With Sheets("OVERTIME").Range("A:A")
    ' find date
    Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

    If Not fndRng Is Nothing Then   'if found
        i = 1
        For Each cel In rng1
            fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
        i = 1
        For Each cel In rng2
            If cel.Value = "A" Then fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
    Else                            'if not found
        MsgBox "Sorry, did not find " & WKend
    End If
End With


'add overtime and absence wednesday
With ActiveSheet
    WKend = .Range("BI2").Value
    Set rng1 = .Range("AO21:AO32")
    Set rng2 = .Range("DE21:DE32")
End With

With Sheets("OVERTIME").Range("A:A")
    ' find date
    Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

    If Not fndRng Is Nothing Then   'if found
        i = 1
        For Each cel In rng1
            fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
        i = 1
        For Each cel In rng2
            If cel.Value = "A" Then fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
    Else                            'if not found
        MsgBox "Sorry, did not find " & WKend
    End If
End With


'add overtime and absence thursday
With ActiveSheet
    WKend = .Range("BY2").Value
    Set rng1 = .Range("AQ21:AQ32")
    Set rng2 = .Range("DG21:DG32")
End With

With Sheets("OVERTIME").Range("A:A")
    ' find date
    Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

    If Not fndRng Is Nothing Then   'if found
        i = 1
        For Each cel In rng1
            fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
        i = 1
        For Each cel In rng2
            If cel.Value = "A" Then fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
    Else                            'if not found
        MsgBox "Sorry, did not find " & WKend
    End If
End With


'add overtime and absence friday
With ActiveSheet
    WKend = .Range("CO2").Value
    Set rng1 = .Range("AS21:AS32")
    Set rng2 = .Range("DI21:DI32")
End With

With Sheets("OVERTIME").Range("A:A")
    ' find date
    Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                        LookIn:=xlValues, _
                        LookAt:=xlPart, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, _
                        MatchCase:=False)

    If Not fndRng Is Nothing Then   'if found
        i = 1
        For Each cel In rng1
            fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
        i = 1
        For Each cel In rng2
            If cel.Value = "A" Then fndRng.Offset(, i) = cel.Value
            i = i + 1
        Next cel
    Else                            'if not found
        MsgBox "Sorry, did not find " & WKend
    End If
End With


     'add overtime saturday no absence
    With ActiveSheet
    WKend = .Range("DE2").Value
    arr = .Range("AU21:AU32").Value
End With

With Sheets("OVERTIME").Range("A:A")
    Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                       LookIn:=xlValues, _
                       LookAt:=xlPart, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlNext, _
                       MatchCase:=False)
                      
    If Not fndRng Is Nothing Then
        fndRng.Offset(, 1).Resize(, UBound(arr)).Value = Application.Transpose(arr)
    Else
        MsgBox "Sorry, did not find " & WKend
    End If
End With


End Sub
Click to expand...

Can you try this and share the result?

VBA Code: 
Sub Button3_Click()

    Dim WKend As Date
    Dim rng1 As Range, rng2 As Range
    Dim fndRng As Range, cel As Range
    Dim i As Long
    Dim combinedValues() As Variant
    Dim arr As Variant

    With ActiveSheet
        WKend = .Range("M2").Value
        Set rng1 = .Range("AI21:AI32")
        Set rng2 = .Range("CY21:CY32")
    End With

    With Sheets("OVERTIME").Range("A:A")
        Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False)
        If Not fndRng Is Nothing Then   'if found
            ReDim combinedValues(1 To rng1.Cells.Count)
            For i = 1 To rng1.Cells.Count
                If rng2.Cells(i).Value = "A" Then
                    combinedValues(i) = rng1.Cells(i).Value & rng2.Cells(i).Value
                Else
                    combinedValues(i) = rng1.Cells(i).Value
                End If
            Next i
            For i = 1 To UBound(combinedValues)
                fndRng.Offset(0, i) = combinedValues(i)
            Next i
        Else                          
            MsgBox "Sorry, did not find " & WKend
        End If
    End With

    With ActiveSheet
        WKend = .Range("AC2").Value
        Set rng1 = .Range("AK21:AK32")
        Set rng2 = .Range("DA21:DA32")
    End With

    ' ... [Copy the same structure for Tuesday, Wednesday, Thursday, and Friday]

    With ActiveSheet
        WKend = .Range("AS2").Value
        Set rng1 = .Range("AM21:AM32")
        Set rng2 = .Range("DC21:DC32")
    End With

    '... [Continue for other days]

    'add overtime saturday no absence
    With ActiveSheet
        WKend = .Range("DE2").Value
        arr = .Range("AU21:AU32").Value
    End With

    With Sheets("OVERTIME").Range("A:A")
        Set fndRng = .Find(What:=Format(WKend, "dd/mm/yy"), _
                           LookIn:=xlValues, _
                           LookAt:=xlWhole, _
                           SearchOrder:=xlByRows, _
                           SearchDirection:=xlNext, _
                           MatchCase:=False)

        If Not fndRng Is Nothing Then
            For i = 1 To UBound(arr, 1)
                fndRng.Offset(0, i) = arr(i, 1)
            Next i
        Else
            MsgBox "Sorry, did not find " & WKend
        End If
    End With

End Sub
 
Upvote 0
Guys, many thanks for your hard work. It seems in my attempt to clarify what I was requesting I have muddied the waters, REALLY SORRY!. As a old spanner monkey I'm finding difficult to put into words exactly what i'm after. Your understanding and patience is much appreciated.
I refer back to my post #19.
In sheet "ABACUS" , for days Sunday to Friday, I have two ranges arr1 and arr2, in two different columns, that I'd wish to add to a row in "OVERTIME". This row is blank but I wish it to follow on in date from the row above. see picture in post #11. The issue is the two ranges arr1 and arr2 need to combine and add to columns B to M and a concurrent date added to column A.
Below are mini sheets of the two ranges from "ABACUS"
LATHE MAGIC ABACUS v8.xlsm
YZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASATAUAVAW
2MONDAY 21/10/24TUESDAY22/10/24
3SELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASK
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19##################################################
20
21OVERTIMESunMonTuesWedsThurFriSat
22BEN THOMAS0.000.000.000.000.000.000.00
23ROBERT FIELD0.000.000.000.000.000.000.00
24ANDREW DOWNING0.000.000.000.000.000.000.00
25#0.000.000.000.000.000.000.00
26MAX MUNRO0.000.000.000.000.000.000.00
27CHLOE JOHNSON-HOLLAND 0.000.000.000.000.000.000.00
28JONATHAN LYONS 0.000.000.000.000.000.000.00
29#0.000.000.000.000.000.000.00
30ADAM TAYLOR0.000.000.000.000.000.000.00
31#0.000.000.000.000.000.000.00
32#0.000.000.000.000.000.000.00
33
ABACUS
Cell Formulas
RangeFormula
AC2AC2=C2-5
AS2AS2=C2-4
Z3Z3=B28
AB3AB3=B29
AD3AD3=B30
AF3AF3=B31
AH3AH3=B32
AJ3AJ3=D3
AL3AL3=B26
AN3AN3=B27
AP3AP3=B28
AR3AR3=B29
AT3AT3=B30
AV3AV3=B31
Y19:AW19Y19=SUM(Y4:Y17)
Z22:Z25Z22=B5
AI22:AI25AI22=SUM(E5,G5,I5,K5,M5,O5,Q5,S5)
AK22:AK25AK22=SUM(U5,W5,Y5,AA5,AC5,AE5,AG5,AI5)
AM22:AM25AM22=SUM(AK5,AM5,AO5,AQ5,AS5,AU5,AW5,AY5)
AO22:AO25AO22=SUM(BA5,BC5,BE5,BG5,BI5,BK5,BM5,BO5)
AQ22:AQ25AQ22=SUM(BQ5,BS5,BU5,BW5,BY5,CA5,CC5,CE5)
AS22:AS25AS22=SUM(CG5,CI5,CK5,CM5,CO5,CQ5,CS5,CU5)
AU22:AU25AU22=SUM(CW5,CY5,DA5,DC5,DE5,DG5,DI5,DK5)
Z26:Z29Z26=B10
AI26:AI29AI26=SUM(E10,G10,I10,K10,M10,O10,Q10,S10)
AK26:AK29AK26=SUM(U10,W10,Y10,AA10,AC10,AE10,AG10,AI10)
AM26:AM29AM26=SUM(AK10,AM10,AO10,AQ10,AS10,AU10,AW10,AY10)
AO26:AO29AO26=SUM(BA10,BC10,BE10,BG10,BI10,BK10,BM10,BO10)
AQ26:AQ29AQ26=SUM(BQ10,BS10,BU10,BW10,BY10,CA10,CC10,CE10)
AS26:AS29AS26=SUM(CG10,CI10,CK10,CM10,CO10,CQ10,CS10,CU10)
AU26:AU29AU26=SUM(CW10,CY10,DA10,DC10,DE10,DG10,DI10,DK10)
Z30:Z32Z30=B15
AI30:AI32AI30=SUM(E15,G15,I15,K15,M15,O15,Q15,S15)
AK30:AK32AK30=SUM(U15,W15,Y15,AA15,AC15,AE15,AG15,AI15)
AM30:AM32AM30=SUM(AK15,AM15,AO15,AQ15,AS15,AU15,AW15,AY15)
AO30:AO32AO30=SUM(BA15,BC15,BE15,BG15,BI15,BK15,BM15,BO15)
AQ30:AQ32AQ30=SUM(BQ15,BS15,BU15,BW15,BY15,CA15,CC15,CE15)
AS30:AS32AS30=SUM(CG15,CI15,CK15,CM15,CO15,CQ15,CS15,CU15)
AU30:AU32AU30=SUM(CW15,CY15,DA15,DC15,DE15,DG15,DI15,DK15)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
R3,AH3,AX3,BN3,CD3,CT3,DJ3Cell Valuecontains "SELECT A TASK"textNO
P3,AF3,AV3,BL3,CB3,CR3,DH3Cell Valuecontains "SELECT A TASK"textNO
N3,AD3,AT3,BJ3,BZ3,CP3,DF3Cell Valuecontains "SELECT A TASK"textNO
BH3,BX3,CN3,DD3,AR3,AB3,L3Cell Valuecontains "SELECT A TASK"textNO
J3,Z3,AP3,BF3,BV3,CL3,DB3Cell Valuecontains "SELECT A TASK"textNO
H3,X3,AN3,BD3,BT3,CJ3,CZ3Cell Valuecontains "SELECT A TASK"textNO
F3,V3,AL3,BB3,BR3,CH3,CX3Cell Valuecontains "SELECT A TASK"textNO
D3,T3,AJ3,AZ3,BP3,CF3,CV3Cell Valuecontains "SELECT A TASK"textNO
AI22:AI32,AK22:AK32,AM22:AM32,AO22:AO32,AQ22:AQ32,AS22:AS32,AU22:AV32Cell Value>0.25textNO
AI22:AI32,AK22:AK32,AM22:AM32,AO22:AO32,AQ22:AQ32,AS22:AS32,AU22:AV32Cell Value<0.24textNO
N25:N32,S25:S32,W25:Y32Cell Valuecontains "#N/A"textNO
E19,G19,I19,K19,M19,O19,Q19,S19,U19,W19,Y19,AA19,AC19,AE19,AG19,AI19,AK19,AM19,AO19,AQ19,AS19,AU19,AW19,AY19,BA19,BC19,BE19,BG19,BI19,BK19,BM19,BO19,BQ19,BS19,BU19,BW19,BY19,CA19,CC19,CE19,CG19,CI19,CK19,CM19,CO19,CQ19,CS19,CU19,CW19,CY19,DA19,DC19,DE19Cell Value=0textNO
D19,F19,H19,J19,L19,N19,P19,R19,T19,V19,X19,Z19,AB19,AD19,AF19,AH19,AJ19,AL19,AN19,AP19,AR19,AT19,AV19,AX19,AZ19,BB19,BD19,BF19,BH19,BJ19,BL19,BN19,BP19,BR19,BT19,BV19,BX19,BZ19,CB19,CD19,CF19,CH19,CJ19,CL19,CN19,CP19,CR19,CT19,CV19,CX19,CZ19,DB19,DD19,DF19Cell Value=0textNO
R3:S3,AH3:AI3,AX3:AY3,BN3:BO3,CD3:CE3,CT3:CU3,DJ3:DK3Cell Value=0textNO
R3:S3,AH3:AI3,AX3:AY3,BN3:BO3,CD3:CE3,CT3:CU3,DJ3:DK3Cell Value=0textNO
P3:Q3,AF3:AG3,AV3:AW3,BL3:BM3,CB3:CC3,CR3:CS3,DH3:DI3Cell Value=0textNO
N3:O3,AD3:AE3,AT3:AU3,BJ3:BK3,BZ3:CA3,CP3:CQ3,DF3:DG3Cell Value=0textNO
L3:M3,AB3:AC3,AR3:AS3,BH3:BI3,BX3:BY3,CN3:CO3,DD3:DE3Cell Value=0textNO
J3:K3,Z3:AA3,AP3:AQ3,BF3:BG3,BV3:BW3,CL3:CM3,DB3:DC3Cell Value=0textNO
F3:G3,V3:W3,AL3:AM3,BB3:BC3,BR3:BS3,CH3:CI3,CX3:CY3Cell Value=0textNO
D3:E3,T3:U3,AJ3:AK3,AZ3:BA3,BP3:BQ3,CF3:CG3,CV3:CW3Cell Value=0textNO
AK5:AK8,AK10:AK13,AK15:AK17Cell Value>0textNO


LATHE MAGIC ABACUS v8.xlsm
CNCOCPCQCRCSCTCUCVCWCXCYCZDADBDCDDDEDFDGDHDIDJDK
225/10/24SATURDAY26/10/24
3SELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASKSELECT A TASK
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19################################################
20
21ABSENCE - ASunMonTuesWedsThurFri
22BEN THOMAS
23ROBERT FIELD
24ANDREW DOWNING
25#
26MAX MUNRO
27CHLOE JOHNSON-HOLLAND
28JONATHAN LYONS
29#
30ADAM TAYLOR
31#
32#
33
ABACUS
Cell Formulas
RangeFormula
CO2CO2=C2-1
DE2DE2=C2
CN3CN3=B29
CP3CP3=B30
CR3CR3=B31
CT3CT3=B32
CV3CV3=B25
CX3CX3=B26
CZ3CZ3=B27
DB3DB3=B28
DD3DD3=B29
DF3DF3=B30
DH3DH3=B31
DJ3DJ3=B32
CN19:DK19CN19=SUM(CN4:CN17)
CY21,DI21,DG21,DE21,DC21,DA21CY21=AI21
CP22:CP25CP22=B5
CP26:CP29CP26=B10
CP30:CP32CP30=B15
Cells with Conditional Formatting
CellConditionCell FormatStop If True
R3,AH3,AX3,BN3,CD3,CT3,DJ3Cell Valuecontains "SELECT A TASK"textNO
P3,AF3,AV3,BL3,CB3,CR3,DH3Cell Valuecontains "SELECT A TASK"textNO
N3,AD3,AT3,BJ3,BZ3,CP3,DF3Cell Valuecontains "SELECT A TASK"textNO
BH3,BX3,CN3,DD3,AR3,AB3,L3Cell Valuecontains "SELECT A TASK"textNO
J3,Z3,AP3,BF3,BV3,CL3,DB3Cell Valuecontains "SELECT A TASK"textNO
H3,X3,AN3,BD3,BT3,CJ3,CZ3Cell Valuecontains "SELECT A TASK"textNO
F3,V3,AL3,BB3,BR3,CH3,CX3Cell Valuecontains "SELECT A TASK"textNO
D3,T3,AJ3,AZ3,BP3,CF3,CV3Cell Valuecontains "SELECT A TASK"textNO
E19,G19,I19,K19,M19,O19,Q19,S19,U19,W19,Y19,AA19,AC19,AE19,AG19,AI19,AK19,AM19,AO19,AQ19,AS19,AU19,AW19,AY19,BA19,BC19,BE19,BG19,BI19,BK19,BM19,BO19,BQ19,BS19,BU19,BW19,BY19,CA19,CC19,CE19,CG19,CI19,CK19,CM19,CO19,CQ19,CS19,CU19,CW19,CY19,DA19,DC19,DE19Cell Value=0textNO
D19,F19,H19,J19,L19,N19,P19,R19,T19,V19,X19,Z19,AB19,AD19,AF19,AH19,AJ19,AL19,AN19,AP19,AR19,AT19,AV19,AX19,AZ19,BB19,BD19,BF19,BH19,BJ19,BL19,BN19,BP19,BR19,BT19,BV19,BX19,BZ19,CB19,CD19,CF19,CH19,CJ19,CL19,CN19,CP19,CR19,CT19,CV19,CX19,CZ19,DB19,DD19,DF19Cell Value=0textNO
R3:S3,AH3:AI3,AX3:AY3,BN3:BO3,CD3:CE3,CT3:CU3,DJ3:DK3Cell Value=0textNO
R3:S3,AH3:AI3,AX3:AY3,BN3:BO3,CD3:CE3,CT3:CU3,DJ3:DK3Cell Value=0textNO
P3:Q3,AF3:AG3,AV3:AW3,BL3:BM3,CB3:CC3,CR3:CS3,DH3:DI3Cell Value=0textNO
N3:O3,AD3:AE3,AT3:AU3,BJ3:BK3,BZ3:CA3,CP3:CQ3,DF3:DG3Cell Value=0textNO
L3:M3,AB3:AC3,AR3:AS3,BH3:BI3,BX3:BY3,CN3:CO3,DD3:DE3Cell Value=0textNO
J3:K3,Z3:AA3,AP3:AQ3,BF3:BG3,BV3:BW3,CL3:CM3,DB3:DC3Cell Value=0textNO
F3:G3,V3:W3,AL3:AM3,BB3:BC3,BR3:BS3,CH3:CI3,CX3:CY3Cell Value=0textNO
D3:E3,T3:U3,AJ3:AK3,AZ3:BA3,BP3:BQ3,CF3:CG3,CV3:CW3Cell Value=0textNO


Below is the code I have, I copied the code for arr1 and and renamed it arr2. The problem with this code is that arr2 is overwriting arr1.

VBA Code: 
Public Sub CopySheetAndRenamePredefined()


    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim response As String
    For Each ws In Sheets
        If ws.Range("B2") <> "" And ws.Range("C2") = "" Then
        Do
            response = InputBox("Input date in format **/**/**")
            If response <> "" Then
            ws.Range("C2") = response
            Exit Do
            ElseIf response = "" Then
            MsgBox ("You must enter date in format **/**/**")

        Else: Exit Do
        End If
    Loop
    
    End If
    Next ws
    Application.ScreenUpdating = True
    
    Dim WKend
    Dim arr As Variant
    Dim writerow As Long

    
     'copy overtime and absence sunday
     With Sheets("ABACUS")
     WKend = .Range("M2").Value2
     arr1 = .Range("AI21:AI32").Value
     arr2 = .Range("CY21:CY32").Value
     End With

     With Sheets("OVERTIME")
     ' last used row in column B plus 1
    
     writerow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
    .Range("A2") = Format(Date, "dd/mm/yy")
    .Range("A" & writerow) = WKend
    .Range("B" & writerow).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    .Range("B" & writerow).Resize(, UBound(arr2)).Value = Application.Transpose(arr2)
    End With
   
   
    'copy overtime and absence monday
    With Sheets("ABACUS")
    WKend = .Range("AC2").Value2
    arr1 = .Range("AK21:AK32").Value
    arr2 = .Range("DA21:DA32").Value
    End With

    With Sheets("OVERTIME")
    ' last used row in column B plus 1
    writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
    .Range("A" & writerow) = WKend
    .Range("B" & writerow).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    .Range("B" & writerow).Resize(, UBound(arr2)).Value = Application.Transpose(arr2)
    End With

    'copy overtime and absence tuesday
    With Sheets("ABACUS")
    WKend = .Range("AS2").Value2
    arr1 = .Range("AM21:AM32").Value
    arr2 = .Range("DC21:DC32").Value
    End With

    With Sheets("OVERTIME")
    ' last used row in column B plus 1
    writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
    .Range("A" & writerow) = WKend
    .Range("B" & writerow).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    .Range("B" & writerow).Resize(, UBound(arr2)).Value = Application.Transpose(arr2)
    End With

    'copy overtime and abence wednesday
    With Sheets("ABACUS")
    WKend = .Range("BI2").Value2
    arr1 = .Range("AO21:AO32").Value
    arr2 = .Range("DE21:DE32").Value
    End With

    With Sheets("OVERTIME")
    ' last used row in column B plus 1
    writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
    .Range("A" & writerow) = WKend
    .Range("B" & writerow).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    .Range("B" & writerow).Resize(, UBound(arr2)).Value = Application.Transpose(arr2)
    End With

    'copy overtime and absence thursday
    With Sheets("ABACUS")
    WKend = .Range("BY2").Value2
    arr1 = .Range("AQ21:AQ32").Value
    arr2 = .Range("DG21:DG32").Value
    End With

    With Sheets("OVERTIME")
    ' last used row in column B plus 1
    writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
    .Range("A" & writerow) = WKend
    .Range("B" & writerow).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    .Range("B" & writerow).Resize(, UBound(arr2)).Value = Application.Transpose(arr2)
    End With

    'copy overtime and absence friday
    With Sheets("ABACUS")
    WKend = .Range("CO2").Value2
    arr1 = .Range("AS21:AS32").Value
    arr2 = .Range("DI21:DI32").Value
    End With

    With Sheets("OVERTIME")
    ' last used row in column B plus 1
     writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
    .Range("A" & writerow) = WKend
    .Range("B" & writerow).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    .Range("B" & writerow).Resize(, UBound(arr2)).Value = Application.Transpose(arr2)
    End With

 'copy overtime saturday
    With Sheets("ABACUS")
        WKend = .Range("DE2").Value2
        arr = .Range("AU21:AU32").Value
    End With

    With Sheets("OVERTIME")
    ' last used row in column B plus 1
    writerow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
    .Range("A" & writerow) = WKend
    .Range("B" & writerow).Resize(, UBound(arr)).Value = Application.Transpose(arr)
    .Range("A" & writerow & ":X" & writerow).Borders(xlEdgeBottom).LineStyle = xlContinuous
    End With
   
      
    
    ActiveSheet.Copy After:=Worksheets("OVERTIME")
    ActiveSheet.Name = "W.E." & Format(Range("C2").Value, "dd.mm.yy")
    ActiveSheet.Shapes("Button 1").Delete
        
 
    ActiveSheet.Buttons.add(75, 150, 150, 100).Select
    With Selection
    .Name = "New Button"
    .OnAction = "Button3_Click"
    .Text = "SAVE CHANGES"
    .Font.Size = 24
    .Font.Bold = True
    ActiveSheet.Range("D5").Select
    End With
  
  
    Worksheets("ABACUS").Activate
    Range("D5:DK17").ClearContents
    Range("CY22:DJ32").ClearContents
    Range("C2").ClearContents
    Range("BP22:CE33").ClearContents
    Range("BE22:BV32").ClearContents
    Range("E3,G3,I3,K3,M3,O3,Q3,S3,U3,W3,Y3,AA3,AC3,AE3,AG3,AI3,AK3,AM3,AO3,AQ3,AS3,AU3,AW3,AY3,BA3,BC3,BE3,BG3,BI3,BK3,BM3,BO3").ClearContents
    Range("BQ3,BS3,BU3,BW3,BY3,CA3,CC3,CE3,CG3,CI3,CK3,CM3,CO3,CQ3,CS3,CU3,CW3,CY3,DA3,DC3,DE3,DG3,DI3,DK3").ClearContents
    [B25] = Range("DM2").Value
    [B26] = Range("DM2").Value
    [B27] = Range("DM2").Value
    [B28] = Range("DM2").Value
    [B29] = Range("DM2").Value
    [B30] = Range("DM2").Value
    [B31] = Range("DM2").Value
    [B32] = Range("DM2").Value
    
    
    End Sub


I wouldn't expect anyone to rewrite the whole code for me, just hopefully amend Sunday so I can use this code for Monday to Friday.

Many thanks, and again sorry for causing the confusion.
 
Upvote 0
Update to code of post 21
VBA Code: 
Sub CopyData_v2()
    
    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim i As Long
    Dim dte As Date
    Dim writeCel As Range

' determine where to start
With Sheets("OVERTIME")
    Set writeCel = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
End With

With ActiveSheet
'-----SUNDAY-----
'add overtime and absence sunday
    dte = .Range("M2").Value
    arr1 = .Range("AI21:AI32").Value
    arr2 = .Range("CY21:CY32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel = dte
    writeCel.Offset(0, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----MONDAY-----
'add overtime and absence monday
    dte = .Range("AC2").Value
    arr1 = .Range("AK21:AK32").Value
    arr2 = .Range("DA21:DA32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(1) = dte
    writeCel.Offset(1, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
    
'-----TUESDAY-----
'add overtime and absence tuesday
    dte = .Range("AS2").Value
    arr1 = .Range("AM21:AM32").Value
    arr2 = .Range("DC21:DC32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(2) = dte
    writeCel.Offset(2, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing
    
'-----WEDNESDAY-----
'add overtime and absence wednesday
    dte = .Range("BI2").Value
    arr1 = .Range("AO21:AO32").Value
    arr2 = .Range("DE21:DE32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(3) = dte
    writeCel.Offset(3, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----THURSDAY-----
'add overtime and absence thursday
    dte = .Range("BY2").Value
    arr1 = .Range("AQ21:AQ32").Value
    arr2 = .Range("DG21:DG32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(4) = dte
    writeCel.Offset(4, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----FRIDAY-----
'add overtime and absence friday
    dte = .Range("CO2").Value
    arr1 = .Range("AS21:AS32").Value
    arr2 = .Range("DI21:DI32").Value
    For i = LBound(arr1) To UBound(arr1)
        If arr2(i, 1) = "A" Then
            arr1(i, 1) = arr2(i, 1)
        End If
    Next i
    ' write to sheet and clear arrays
    writeCel.Offset(5) = dte
    writeCel.Offset(5, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing
    Set arr2 = Nothing

'-----SATURDAY-----
'add overtime saturday no absence
    dte = .Range("DE2").Value
    arr1 = .Range("AU21:AU32").Value
    ' write to sheet and clear array
    writeCel.Offset(6) = dte
    writeCel.Offset(6, 1).Resize(, UBound(arr1)).Value = Application.Transpose(arr1)
    Set arr1 = Nothing

End With

End Sub

My last attempt without an actual workbook to test on.
 
  • Like
Reactions: bdt
Upvote 0
Solution
NoSparks, you are amazing. You have solved my problem. Thanks for your patience.
 
Upvote 0
No problem, I had read your edit here and couldn't get over it
anyway glad we got it sorted out in the end
good luck with the rest of your project.
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Solved
changing date format
Replies
5
Views
137
NoSparks
N
B
  • Solved
refering to a worksheet with a changing name
2
Replies
17
Views
338
bdt
B
B
  • Question Question
Error message when copying and renaming a worksheet
2
Replies
13
Views
229
smozgur
smozgur
B
  • Locked
  • Question Question
copy range of cells
Replies
1
Views
53
Joe4
Joe4
B
  • Solved
add a border to bottom of a row
Replies
4
Views
73
bdt
B

Forum statistics

Threads
1,222,834
Messages
6,168,525
Members
452,194
Latest member
Lowie27

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