Add a formula in 28th row

bdt · Oct 19, 2024

Hi guys.
Don't know if this is possible. I have a code that I'd like to add formula to. Presently, when running the code, 7 rows are added to sheet "OVERTIME" which are dates and days, sunday to saturday, along with where required a number and a letter "A" and a border added to the bottom of the last row.
What I would like is once 4 weeks have been added, 28 rows, a simple sum formula is added in columns N to X in the 28th row to add the numbers in columns C to M for the last 4 weeks. Also ideally like a heavy border line to be added to the bottom of row 28 to differentiate each 4 week period.
Below is a mini sheet of "OVERTIME"

LATHE MAGIC ABACUS v10.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

257

06/09/24

Fri

A

4

258

07/09/24

Sat

4

259

08/09/24

Sun

4

A

4

260

09/09/24

Mon

4

A

4

A

4

261

10/09/24

Tues

4

A

4

A

4

262

11/09/24

Weds

A

4

A

4

263

12/09/24

Thur

4

A

264

13/09/24

Fri

4

A

265

14/09/24

Sat

266

15/09/24

Sun

4

A

267

16/09/24

Mon

A

4

268

17/09/24

Tues

A

269

18/09/24

Weds

4

A

270

19/09/24

Thur

4

A

4

271

20/09/24

Fri

A

4

272

21/09/24

Sat

273

22/09/24

Sun

A

274

23/09/24

Mon

A

275

24/09/24

Tues

A

276

25/09/24

Weds

A

277

26/09/24

Thur

4

A

4

278

27/09/24

Fri

4

A

4

279

28/09/24

Sat

280

29/09/24

Sun

4

281

30/09/24

Mon

A

4

282

01/10/24

Tues

A

283

02/10/24

Weds

A

284

03/10/24

Thur

A

285

04/10/24

Fri

A

286

05/10/24

Sat

287

06/10/24

Sun

A

OVERTIME

Cell Formulas
Range	Formula
N286:X286,N258:X258	N258	=SUM(C231:C258)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C1:M154,C155:F155,H155:J155,C156:J159,K155:M159,C160:M1048576	Cell Value	=0	text	NO
C167:M735	Cell Value	contains "A"	text	NO

The code, with the great effort from you guys, is

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 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
      
    
    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
    ActiveWorkbook.Save
    
    End Sub

I have another button (Button 3) in another module which I need do to a similar operation. Hopefully I will be able to sort this one if you guys can do your magic on the above code.
Many thanks

NoSparks · Oct 19, 2024

On what row do these dates in column A start and what is that first date ?

bdt · Oct 19, 2024

Hi. The dates in column A are rolling dates. The dates in column A start from the row after the row with the sums in N to X. So in the example below the sum for column A would be rows 287 to 314. I have added ?s in the row where the total for the sums would be.
This would then repeat for the next 28 days on so on.
Hope this helps

LATHE MAGIC ABACUS v10.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

285

04/10/24

Fri

A

286

05/10/24

Sat

287

06/10/24

Sun

A

288

07/10/24

Mon

4

A

4

289

08/10/24

Tues

A

290

09/10/24

Weds

4

A

4

291

10/10/24

Thur

A

292

11/10/24

Fri

A

293

12/10/24

Sat

294

13/10/24

Sun

0

295

14/10/24

Mon

0

A

0

296

15/10/24

Tues

0

A

0

A

0

297

16/10/24

Weds

0

A

0

A

0

298

17/10/24

Thur

0

A

0

299

18/10/24

Fri

A

0

300

19/10/24

Sat

0

301

20/10/24

Sun

0

302

21/10/24

Mon

0

303

22/10/24

Tues

0

304

23/10/24

Weds

0

305

24/10/24

Thur

0

306

25/10/24

Fri

0

307

26/10/24

Sat

0

308

309

310

311

312

313

314

?

315

316

OVERTIME

Cell Formulas
Range	Formula
N286:X286	N286	=SUM(C259:C286)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C1:M154,C155:F155,H155:J155,C156:J159,K155:M159,C160:M1048576	Cell Value	=0	text	NO
C167:M735	Cell Value	contains "A"	text	NO

NoSparks · Oct 19, 2024

call this sub right after setting arr1 to Nothing on the Saturday

VBA Code:

Sub Formulas_28th_row()
    
    Dim frstCel As Range
    Dim fillRng As Range
    
With Sheets("OVERTIME")
    Set frstCel = .Range("N" & .Rows.Count).End(xlUp).Offset(28)
    Set fillRng = frstCel.Resize(, 11)
    frstCel.FormulaR1C1 = "=SUM(R[-27]C[-11]:RC[-11])"
    frstCel.AutoFill Destination:=fillRng
    
    With .Range("A" & fillRng.Row & ":X" & fillRng.Row).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
    End With
    
End With

End Sub

bdt · Oct 19, 2024

NoSparks, you have done it again, many many thanks.
I've noticed somewhere along the line, the light weight border to the bottom off the rows for each saturday for weeks 1 to 3 are no longer added when the code is run for the first three weeks out of four weeks.
I was using the code below, but when I've tried to add this line the border does not get added. Any thoughts on this?

VBA Code:

.Range("A" & writerow & ":X" & writerow).Borders(xlEdgeBottom).LineStyle = xlContinuous

Below is the mini sheet showing the border to the bottom of the saturdays for weeks 1 to 3 are missing.

LATHE MAGIC ABACUS v11.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

313

01/11/24

Fri

0

314

02/11/24

Sat

0

315

03/11/24

Sun

0

316

04/11/24

Mon

0

317

05/11/24

Tues

0

318

06/11/24

Weds

0

319

07/11/24

Thur

0

320

08/11/24

Fri

0

321

09/11/24

Sat

0

322

10/11/24

Sun

0

323

11/11/24

Mon

0

324

12/11/24

Tues

0

325

13/11/24

Weds

0

326

14/11/24

Thur

0

327

15/11/24

Fri

0

328

16/11/24

Sat

0

329

17/10/24

Sun

4

0

330

18/10/24

Mon

0

331

19/10/24

Tues

0

332

20/10/24

Weds

0

333

21/10/24

Thur

0

334

22/10/24

Fri

0

335

23/10/24

Sat

0

336

24/11/24

Sun

0

337

25/11/24

Mon

0

338

26/11/24

Tues

0

339

27/11/24

Weds

0

340

28/11/24

Thur

0

341

29/11/24

Fri

0

342

30/11/24

Sat

0

4

0

343

OVERTIME

Cell Formulas
Range	Formula
N342:X342,N314:X314	N314	=SUM(C287:C314)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C1:M154,C155:F155,H155:J155,C156:J159,K155:M159,C160:M1048576	Cell Value	=0	text	NO
C167:M735	Cell Value	contains "A"	text	NO

Many thanks

NoSparks · Oct 19, 2024

I can't really see that being the solution because it would be called every week and you'll end up with 4 times more formulas than needed extending way down the sheet.

I would think you only want the formulas added probably the first week ?

When you say rolling dates, do you mean earlier rows of dates are deleted and the others move up
or do you mean that date just keep getting added to the bottom of the existing ?

bdt said:
I was using the code below, but when I've tried to add this line the border does not get added. Any thoughts on this?

That line says the line style is continuous (not dotted or dashed), you need a line after that for the weight of the line (ie: xlThin)
Just noticed the variable writeRow does not exist in the code you've posted here so you must be confusing different subs

bdt · Oct 19, 2024

Thanks for your reply.
Below is the format I was hoping to achieve. Rolling dates refer to the dates getting added after the existing dates. Unfortunately the mini sheet does not make it that obvious each saturday has a border on the bottom of the row and the fourth saturday has a heavier weight border, this heavier border you have already supplied.
I have no idea how to add this border to the bottom of saturdays row for weeks 1 to 3.

LATHE MAGIC ABACUS v11.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

230

10/08/24

Sat

231

11/08/24

Sun

A

232

12/08/24

Mon

A

233

13/08/24

Tues

A

234

14/08/24

Weds

4

A

235

15/08/24

Thur

4

236

16/08/24

Fri

4

237

17/08/24

Sat

238

18/08/24

Sun

A

4

239

19/08/24

Mon

A

240

20/08/24

Tues

A

241

21/08/24

Weds

A

242

22/08/24

Thur

A

243

23/08/24

Fri

A

244

24/08/24

Sat

4

245

25/08/24

Sun

4

A

8

4

246

26/08/24

Mon

A

4

A

4

247

27/08/24

Tues

4

A

4

A

248

28/08/24

Weds

A

4

A

4

249

29/08/24

Thur

8

4

A

250

30/08/24

Fri

4

A

8

251

31/08/24

Sat

8

252

01/09/24

Sun

4

A

4

8

253

02/09/24

Mon

4

A

4

A

4

254

03/09/24

Tues

4

A

4

A

4

255

04/09/24

Weds

4

A

4

A

4

256

05/09/24

Thur

A

8

4

257

06/09/24

Fri

A

4

258

07/09/24

Sat

4

259

08/09/24

Sun

4

A

4

OVERTIME

Cell Formulas
Range	Formula
N258:X258,N230:X230	N230	=SUM(C203:C230)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C1:M154,C155:F155,H155:J155,C156:J159,K155:M159,C160:M1048576	Cell Value	=0	text	NO
C167:M735	Cell Value	contains "A"	text	NO

NoSparks · Oct 19, 2024

If you pick a row in the first week of the 28 day (4 week) cycle to be your base starting point
you can count the Saturdays up to and including the one you are currently writing.
You can then MOD that count by 4 to figure out which of the 4 weeks you're working with.

The mini sheets are too mini to show what I asked in post 2 and the picture in your previous thread had the rows hidden
so I may be wrong using row 10 but with this you should get the idea, I believe it will be Wednesday of the first week.

This will look after inserting the formulas and the underlining of Saturday without the separate sub.

VBA Code:

Sub Data_To_OVERTIME()
    
    Dim arr1 As Variant
    Dim arr2 As Variant
    Dim i As Long
    Dim dte As Date
    Dim writeCel As Range
    Dim writeRow As Long
    
' determine where to start
With Sheets("OVERTIME")
    Set writeCel = .Range("A" & .Rows.Count).End(xlUp).Offset(1)
End With

With ActiveSheet    ' ABACUS when testing
'-----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
    
    '-----For formulas and/or under lining-------
    writeRow = writeCel.Offset(6, 1).Row
    With Sheets("OVERTIME")
        'Debug.Print Application.CountIf(.Range("B10:B" & writeRow), "Sat") Mod 4
        If Application.CountIf(.Range("B10:B" & writeRow), "Sat") Mod 4 = 0 Then
            .Range("N" & writeRow).FormulaR1C1 = "=SUM(R[-27]C[-11]:RC[-11])"
            .Range("N" & writeRow).AutoFill Destination:=.Range("N" & writeRow).Resize(, 11)
            With .Range("A" & writeRow & ":X" & writeRow).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThick
            End With
        Else
            With .Range("A" & writeRow & ":X" & writeRow).Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
            End With
        End If
    End With
    
End Sub

bdt · Oct 20, 2024

NoSparks, once again you are a genius. Despite my not very clear description of what I was hoping to achieve you have given me exactly what I was after.
Many thanks

bdt · Oct 20, 2024

A final one, is there a way to center the values in columns N:X, rather than the current set to the right.
I've tried putting the code below in various places but still can't center the the columns.

VBA Code:

.HorizontalAlignment = xlCenter

Thanks

Add a formula in 28th row

bdt

Board Regular

Excel Facts

NoSparks

Well-known Member

bdt

Board Regular

NoSparks

Well-known Member

bdt

Board Regular

NoSparks

Well-known Member

bdt

Board Regular

NoSparks

Well-known Member

bdt

Board Regular

bdt

Board Regular

Similar threads

Forum statistics

Share this page

Add a formula in 28th row

Board Regular

Excel Facts

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Board Regular

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