Excel VBA: How to copy multiple ranges from same sheet

Question

I'm very new to VBA. I have a sheet that has multiple ranges I'd like to copy and paste into news spreadsheets. The first range is C2:I37, and the next begins exactly 36 cells below at C38:I73, and the next one exactly 36 cells below that at C74:I109, and so on. In total, there are 32 ranges that I need to copy, all from the same sheet, and all equal distance apart.

I can achieve this for the first range (C2:I37) in the macro given below (it does a few other things that are not relevant to this question). But I don't know how to do this in an efficient way for the remaining 31 ranges. Any feedback is appreciated.

Sub copy()
'
' copy Macro
'

'
    Range("C2:I37").Select
    Selection.copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "onsets1"
    ThisFile = Range("G1").Value
    ActiveWorkbook.SaveAs Filename:=ThisFile
    Range("G1").Select
    Selection.ClearContents
    ActiveWorkbook.Save
End Sub

Answer 1

You can do this with a loop structure. I'm assuming that your filenames are also every 36 cells, e.g., G1, then G37, etc. If not, then we'll need to make some slight modification.

This avoids the need to Select or Activate anything, and transfers values more efficiently via direct assignment rather than using Copy/PasteSpecial

(This creates a new workbook for each copied range)

Dim rangeToCopy as Range
Dim fileNameRange as Range
Dim i as Long
Dim newWorkbook as Workbook
Dim fileName as String

With ThisWorkbook.Worksheets(" insert your worksheet name here")
    Set rngToCopy = .Range("C2:I37")
    Set fileNameRange = .Range("G1")
End With
For i = 1 to 32
    Set newWorkbook = Workbooks.Add
    newWorkbook.Worksheets(1).Range("A1").Resize(rngToCopy.Rows.Count, rngToCopy.Columns.Count).Value = rngToCopy.Value
    newWorkbook.Worksheets(1).Name = "onsets1"  ' Modify if needed
    fileName = fileNameRange.Value
    fileNameRange.ClearContents
    newWorkbook.SaveAs Filename:=fileName

    ' Increment our ranges:
    Set fileNameRange = fileNameRange.Offset(36)
    Set rngToCopy = rngToCopy.Offset(36)
Next
ThisWorkbook.Save