Hello Andrew,
Sorry for the delay in replying, I have been away.
I attach all of the code. It is probably more that you need, but better have it all than miss something vital.
I have indicated - within the code, places where my query arises and what I hope to achieve. Not sure how to attach code other than to copy and paste below.
At the moment I am having to set the first formula in each table, then fill in each table.
Thanks Dbus
Option Private Module
Sub CalcResults1()
'This macro calculates the values into Tables 0.0, 1.0, 1.1, 1.2 & 1.3
Dim WkSh As Worksheet
Dim AnchorCell As Range, MyHder As Range, MyF As Range
Dim Mycell As Range, MyRng As Range
Dim ColIndex As Range, Rng As Range, Name As Range
Dim Bm As Long, Rt As Long
' check to ensure correct sheet is active
Set Mycell = Range("A1")
If Mycell.Value = "T0.0" Or Mycell.Value = "T1.0" Or _
Mycell.Value = "T1.1" Or Mycell.Value = "T1.2" Or _
Mycell.Value = "T1.3" Then
'' still need to find way to stop spreadsheet displaying all steps
Call CalcNegValues1
Call CalcRepValues1
Call CalcIntValues1
Else
MsgBox "Check that you have the correct sheet open"
Exit Sub
End If
End Sub
Sub CalcNegValues1()
Dim ColIndex As Range
Set WkSh = ActiveSheet
Set AnchorCell = Cells.Find(What:="AllNeg1")
TbBm = Range("E9").End(xlDown).Row - 9 'Last row in Dest table
Application.CutCopyMode = True
' Calculates the number to which the column relates (Column C = 3)
Set Rng = Range("8:8")
Rng.Name = "MyRng"
AnchorCell.Name = "MyName"
Range("MyName").Select
Set ColIndex = AnchorCell.Offset(-2, 0)
ColIndex = "=MATCH(MyName,MyRng,0)"
Application.ScreenUpdating = False
' Sets appropriate formula reference
Sheets("Frmla").Activate
Set MyF = Cells.Find(What:="NoClmts").Offset(0, 1)
Application.ScreenUpdating = True
' Coding to fill each cell with relevant formula,
' calculate result and convert result to value
WkSh.Activate
'' Set first formula for No. of Claimants in each table
'' (Cells F9, Y9 and AR9)
Set MyCell2 = AnchorCell.Offset(1, 1)
MyCell2.Select
With MyCell2
.Formula = "=" & MyF.Value
.Copy
.Offset(0, 19).PasteSpecial Paste:=xlPasteFormulas
ActiveCell.Copy
ActiveCell.Offset(0, 19).PasteSpecial Paste:=xlPasteFormulas
End With
For c = ColIndex To ColIndex + 40 Step 19
'' Fill No. of Claimants (Columns F, Y and AR from row 9 to 43)
TbBm = Range("E9").End(xlDown).Row - 9 'Last row in Dest table
Set MyCell3 = Cells(9, c + 1)
Set MyRng = Range(MyCell3.Offset(0, 0), MyCell3.Offset(TbBm, 0))
MyCell3.AutoFill Destination:=MyRng, Type:=xlFillDefault
MyRng.Value = MyRng.Value
'' Set first formula for No. of Inspections in each table
'' (Cells G9, Z9 and AS9)
Set MyCell2 = AnchorCell.Offset(1, 2)
MyCell2.Select
With MyCell2
.Formula = "=" & MyF.Offset(1, 0).Value
.Copy
.Offset(0, 19).PasteSpecial Paste:=xlPasteFormulas
ActiveCell.Copy
ActiveCell.Offset(0, 19).PasteSpecial Paste:=xlPasteFormulas
End With
'' Fill No. of Inspections (Columns G, Z and AS from row 9 to 43)
Set MyCell3 = Cells(9, c + 2)
Set MyRng = Range(MyCell3.Offset(0, 0), MyCell3.Offset(TbBm, 0))
MyCell3.AutoFill Destination:=MyRng, Type:=xlFillDefault
MyRng.Value = MyRng.Value
'' Set first formula for No of Single '%' penalties
'' Cells J9, L9, N9 and P9 repeated from AC9 and AV9
'' Would like to remove need to repeat code
Set MyCell2 = AnchorCell.Offset(1, 5)
MyCell2.Select
With MyCell2
.Formula = "=" & MyF.Offset(2, 0).Value
.Copy
.Offset(0, 2).PasteSpecial Paste:=xlPasteFormulas
ActiveCell.Copy
ActiveCell.Offset(0, 2).PasteSpecial Paste:=xlPasteFormulas
ActiveCell.Copy
ActiveCell.Offset(0, 2).PasteSpecial Paste:=xlPasteFormulas
End With
Set MyRng2 = Range(MyCell2, MyCell2.Offset(0, 7))
With MyRng2
.Copy
.Offset(2, 0).PasteSpecial Paste:=xlPasteFormulas
End With
Set MyRng3 = Range(MyCell2, MyCell2.Offset(3, 7))
With MyRng3
.Copy
.Offset(0, 19).PasteSpecial Paste:=xlPasteFormulas
.Offset(0, 38).PasteSpecial Paste:=xlPasteFormulas
End With
'' Set first formula for No of Multiple '%' penalties
'' Cells S9 & U9 repeated from AL9 and BE9
'' Would like to remove need to repeat code
Set MyCell2 = AnchorCell.Offset(1, 14)
With MyCell2
.Formula = "=" & MyF.Offset(3, 0).Value
.Copy
.Offset(0, 2).PasteSpecial Paste:=xlPasteFormulas
End With
Set MyRng2 = Range(MyCell2, MyCell2.Offset(0, 3))
With MyRng2
.Copy
.Offset(2, 0).PasteSpecial Paste:=xlPasteFormulas
End With
Set MyRng3 = Range(MyCell2, MyCell2.Offset(3, 3))
With MyRng3
.Copy
.Offset(0, 19).PasteSpecial Paste:=xlPasteFormulas
.Offset(0, 38).PasteSpecial Paste:=xlPasteFormulas
End With
Range("J9:BG11").Value = Range("J9:BG11").Value
'' Set first formula for No of Single '%' penalties per Standard
'' Cells J14, L14, N14 and P14 repeated from AC14 and AV14
'' Would like to remove need to repeat code
TbBm = Range("E14").End(xlDown).Row - 14 'Last row in Dest table
Set MyCell2 = AnchorCell.Offset(6, 5)
With MyCell2
.Formula = "=" & MyF.Offset(4, 0).Value
.Copy
.Offset(0, 2).PasteSpecial Paste:=xlPasteFormulas
ActiveCell.Copy
ActiveCell.Offset(0, 2).PasteSpecial Paste:=xlPasteFormulas
ActiveCell.Copy
ActiveCell.Offset(0, 2).PasteSpecial Paste:=xlPasteFormulas
End With
Set MyHder2 = Range(MyCell2, MyCell2.Offset(0, 6))
With MyHder2
.Copy
.Offset(0, 19).PasteSpecial Paste:=xlPasteFormulas
.Offset(0, 38).PasteSpecial Paste:=xlPasteFormulas
End With
Application.CutCopyMode = False
'' Fill No of Single '%' penalties per Standard
'' Fill Columns J, L, N & P and AC & AV from row 14 to 43)
TbBm = Range("E14").End(xlDown).Row - 14 'Last row in Dest table
Set MyCell3 = Cells(14, c + 5)
Set MyRng = Range(MyCell3.Offset(0, 0), MyCell3.Offset(TbBm, 7))
Set MyHder = Range(MyCell3.Offset(0, 0), MyCell3.Offset(0, 7))
MyHder.AutoFill Destination:=MyRng, Type:=xlFillDefault
MyRng.Value = MyRng.Value
Next c
ColIndex.ClearContents
End Sub
Sub CalcRepValues1()
'' Would like to remove need to repeat formula
'' Same formula used in BL13 as BM13 & BN13, repeated from BQ13 and BV13
Dim ColIndex As Range
Set WkSh = ActiveSheet
Set AnchorCell = Cells.Find(What:="AllRep1")
TbBm = Range("E13").End(xlDown).Row - 13 'Last row in Dest table
Application.CutCopyMode = True
Set Rng = Range("12:12")
Rng.Name = "MyRng"
AnchorCell.Name = "MyName"
Range("MyName").Select
Set ColIndex = AnchorCell.Offset(-1, 1)
ColIndex = "=MATCH(MyName,MyRng,0)"
Application.ScreenUpdating = False
Sheets("Frmla").Activate
Set MyF = Cells.Find(What:="AllRep1").Offset(0, 1)
Application.ScreenUpdating = True
WkSh.Activate
Set MyCell2 = AnchorCell.Offset(1, 0)
With MyCell2
.Formula = "=" & MyF.Value
.Copy
'' the following 2 lines allow the formula to move across to next subtable
.Offset(0, 5).PasteSpecial Paste:=xlPasteFormulas
ActiveCell.Copy
ActiveCell.Offset(0, 5).PasteSpecial Paste:=xlPasteFormulas
End With
Application.CutCopyMode = False
For c = ColIndex To ColIndex + 13 Step 5
Set MyCell3 = Cells(13, c)
Set MyRng = Range(MyCell3.Offset(0, 1), MyCell3.Offset(TbBm, 3))
Set MyHder = Range(MyCell3, MyCell3.Offset(0, 3))
MyCell3.AutoFill Destination:=Range(MyHder, MyHder), Type:=xlFillDefault
Set MyHder = Range(MyCell3.Offset(0, 1), MyCell3.Offset(0, 3))
MyHder.AutoFill Destination:=MyRng, Type:=xlFillDefault
MyRng.Value = MyRng.Value
MyCell3.Value = MyCell3.Value
Next c
ColIndex.ClearContents
End Sub
Sub CalcIntValues1()
Dim ColIndex As Range
Set WkSh = ActiveSheet
Set AnchorCell = Cells.Find(What:="AllInt1")
TbBm = Range("E13").End(xlDown).Row - 13 'Last row in Dest table
Application.CutCopyMode = True
Set Rng = Range("12:12")
Rng.Name = "MyRng"
AnchorCell.Name = "MyName"
Range("MyName").Select
Set ColIndex = AnchorCell.Offset(-1, 1)
ColIndex = "=MATCH(MyName,MyRng,0)"
Application.ScreenUpdating = False
Sheets("Frmla").Activate
Set MyF = Cells.Find(What:="AllInt1").Offset(0, 1)
Application.ScreenUpdating = True
WkSh.Activate
Set MyCell2 = AnchorCell.Offset(1, 0)
With MyCell2
.Formula = "=" & MyF.Value
.Copy
.Offset(0, 6).PasteSpecial Paste:=xlPasteFormulas
ActiveCell.Copy
ActiveCell.Offset(0, 6).PasteSpecial Paste:=xlPasteFormulas
End With
Application.CutCopyMode = False
For c = ColIndex To ColIndex + 15 Step 6
Set MyCell3 = Cells(13, c)
Set MyRng = Range(MyCell3.Offset(0, 1), MyCell3.Offset(TbBm, 2))
Set MyHder = Range(MyCell3, MyCell3.Offset(0, 2))
MyCell3.AutoFill Destination:=Range(MyHder, MyHder), Type:=xlFillDefault
Set MyHder = Range(MyCell3.Offset(0, 1), MyCell3.Offset(0, 2))
MyHder.AutoFill Destination:=MyRng, Type:=xlFillDefault
MyRng.Value = MyRng.Value
MyCell3.Value = MyCell3.Value
Next c
ColIndex.ClearContents
Range("A1").Select
End Sub
Sub ClearValues()
Range("F9:BI43").ClearContents
Range("BK13:CP43").ClearContents
End Sub