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

you want to paste 32 ranges on separate 32 sheets or only sheet? — Ahmed Hassan
– Ahmed Hassan, Commented Jul 28, 2018 at 14:20

David Zemens · Accepted Answer · 2018-07-29 12:47:39Z

4

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

edited Jul 29, 2018 at 12:47

answered Jul 28, 2018 at 14:29

David Zemens

53.8k12 gold badges86 silver badges132 bronze badges

Sign up to request clarification or add additional context in comments.

2 Comments

pomodoro Over a year ago

Yes, the file name is in G1 and every 36 cells. This script worked perfectly for me, and is exactly what I was after. Thank you!

GMalc Over a year ago

Up-vote; Super use of variables and not using Copy/Paste and your use of Offset to reset your range variables. But, shouldn't Fiename:= ThisFile be Filename:=fileName?

QHarr · Accepted Answer · 2018-07-28 15:06:47Z

Bit of maths will give you the ranges. Assuming all go into one workbook as I can't see you setting any new names for workbooks.

Option Explicit
Public Sub GatherRanges()
    Dim i As Long, unionRng As Range, r As Long, ws As Worksheet, rng As Range, thisFile As String
    Set ws = ThisWorkbook.Worksheets("Sheet1")

    With Worksheets("Sheet1")
        Set rng = .Range("C2:I37")
        For i = 1 To 32
            r = 72 * i - 72
            If Not unionRng Is Nothing Then
                Set unionRng = Union(unionRng, .Range("C2:I37").Offset(r, 0))
            Else
                Set unionRng = .Range("C2:I37").Offset(r, 0)
            End If
        Next i

    thisFile = ws.Range("G1")

    If Not unionRng Is Nothing Then
        unionRng.Copy
        Dim wb As Workbook
        Set wb = Workbooks.Add
        wb.Worksheets("Sheet1").Name = "onsets1"
        wb.SaveAs Filename:=thisFile
    End If
    End With
End Sub

If going to different workbooks you need some code to change the filename but the surrounding code could be:

Option Explicit
Public Sub GatherRanges()
    Dim i As Long, r As Long, ws As Worksheet, rng As Range, thisFile As String, wb As Workbook
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    With ws
        Set rng = .Range("C2:I37")
        For i = 1 To 32
            r = 72 * i - 72
            .Range("C2:I37").Offset(r, 0).Copy
            'some code to change filename ??????
            thisFile = ws.Range("G1")
            Set wb = Workbooks.Add
            wb.Worksheets("Sheet1").Name = "onsets1"
            wb.SaveAs Filename:=thisFile
        Next i
    End With
End Sub

Ahmed Hassan · Accepted Answer · 2018-07-28 14:26:58Z

0

modify this loop according to your macro.

Dim a As Integer
Dim b As Integer

a = 2
b = 37

For x = 1 To 32

Sheets(act_ws).Activate
Range("C" & a & ":I" & b).copy
Sheets("Tempo").Activate
Range("C" & a & ":I" & b).PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, transpoe:=False
a = a + 36
b = b + 36
Next

answered Jul 28, 2018 at 14:26

Ahmed Hassan

1101 gold badge2 silver badges7 bronze badges

Collectives™ on Stack Overflow

Excel VBA: How to copy multiple ranges from same sheet

3 Answers 3

2 Comments

Comments

Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

2 Comments

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related