VBA Shorten Code

[BenGee]

Hey I was wondering if there's a way to shorten this code without having to list each range as I'm having to do this 30+ times?

Here it is;

Sub Button4_Click()

'Person 1
    Range("G3").FormulaArray = Sheets("Person1 3CT").Range("I24")
    Range("G4").FormulaArray = Sheets("Person1 3CT").Range("M24")
    Range("G5").FormulaArray = Sheets("Person1 3CT").Range("Q24")
    Range("I3").FormulaArray = Sheets("Person1 3CT").Range("I62")
    Range("I4").FormulaArray = Sheets("Person1 3CT").Range("M62")
    Range("I5").FormulaArray = Sheets("Person1 3CT").Range("Q62")
    Range("K3").FormulaArray = Sheets("Person1 3CT").Range("I100")
    Range("K4").FormulaArray = Sheets("Person1 3CT").Range("M100")
    Range("K5").FormulaArray = Sheets("Person1 3CT").Range("Q100")
    Range("P3").FormulaArray = Sheets("Person1 3CT").Range("I138")
    Range("P4").FormulaArray = Sheets("Person1 3CT").Range("M138")
    Range("P5").FormulaArray = Sheets("Person1 3CT").Range("Q138")
    Range("R3").FormulaArray = Sheets("Person1 3CT").Range("I176")
    Range("R4").FormulaArray = Sheets("Person1 3CT").Range("M176")
    Range("R5").FormulaArray = Sheets("Person1 3CT").Range("Q176")
    Range("T3").FormulaArray = Sheets("Person1 3CT").Range("I214")
    Range("T4").FormulaArray = Sheets("Person1 3CT").Range("M214")
    Range("T5").FormulaArray = Sheets("Person1 3CT").Range("Q214")

'Person 2
    Range("G6").FormulaArray = Sheets("Person 2 3CT").Range("I24")
    Range("G7").FormulaArray = Sheets("Person 2 3CT").Range("M24")
    Range("G8").FormulaArray = Sheets("Person 2 3CT").Range("Q24")
    Range("I6").FormulaArray = Sheets("Person 2 3CT").Range("I62")
    Range("I7").FormulaArray = Sheets("Person 2 3CT").Range("M62")
    Range("I8").FormulaArray = Sheets("Person 2 3CT").Range("Q62")
    Range("K6").FormulaArray = Sheets("Person 2 3CT").Range("I100")
    Range("K7").FormulaArray = Sheets("Person 2 3CT").Range("M100")
    Range("K8").FormulaArray = Sheets("Person 2 3CT").Range("Q100")
    Range("P6").FormulaArray = Sheets("Person 2 3CT").Range("I138")
    Range("P7").FormulaArray = Sheets("Person 2 3CT").Range("M138")
    Range("P8").FormulaArray = Sheets("Person 2 3CT").Range("Q138")
    Range("R6").FormulaArray = Sheets("Person 2 3CT").Range("I176")
    Range("R7").FormulaArray = Sheets("Person 2 3CT").Range("M176")
    Range("R8").FormulaArray = Sheets("Person 2 3CT").Range("Q176")
    Range("T6").FormulaArray = Sheets("Person 2 3CT").Range("I214")
    Range("T7").FormulaArray = Sheets("Person 2 3CT").Range("M214")
    Range("T8").FormulaArray = Sheets("Person 2 3CT").Range("Q214")
End Sub

The range before the ".FormulaArray" is in the activeworksheet and will always have the same column reference but the row will increase (so person 1' rows will be 3,4,5 and person 2 will be 6,7,8 and person 3 will be rows 9,10,11 and this will continue to row 105,106,107).

The sheet names "Person 1" / "Person 2" are not the actual worksheet names and will vary by worksheet. But, will always have 3CT at the end of the worksheet name. However, each of the ranges within these worksheets will stay the same.

Any help would be hugely appreciated but equally understanding if the above is the simplest way.

Thank you

 

[Norie]

Do you have an ordered list of the actual names?

PS Are you actually putting array formulas into the cells?

 

[Rick Rothstein]

This is untested as I am about to go to sleep. Assuming your person sheets (the ones that end with 3CT) are in the correct order (left to right) for where Person1, Person2, etc. are to be processed for your assignments, then I think this should be all you need...

[table="width: 500"]
[tr]
	[td]Sub Button4_Click()
  Dim ShtNum As Long, X As Long, WS As Worksheet
  For ShtNum = 1 To Sheets.Count
    Set WS = Sheets(ShtNum)
    If Sheets(ShtNum).Name Like "*3CT" Then
      Range("G3:G5").Offset(3 * X).FormulaArray = Application.Index(WS.Cells, 24, [{9;13;17}])
      Range("I3:I5").Offset(3 * X).FormulaArray = Application.Index(WS.Cells, 62, [{9;13;17}])
      Range("K3:K5").Offset(3 * X).FormulaArray = Application.Index(WS.Cells, 100, [{9;13;17}])
      Range("P3:P5").Offset(3 * X).FormulaArray = Application.Index(WS.Cells, 138, [{9;13;17}])
      Range("R3:R5").Offset(3 * X).FormulaArray = Application.Index(WS.Cells, 176, [{9;13;17}])
      Range("T3:T5").Offset(3 * X).FormulaArray = Application.Index(WS.Cells, 214, [{9;13;17}])
      X = X + 1
    End If
  Next
End Sub[/td]
[/tr]
[/table]

 

[BenGee]

Thanks for both of your help

Rick - This worked perfectly, thank you!