Excel VBA: How to copy multiple ranges from same sheet

问题

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

回答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

回答2:

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

回答3:

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

来源：https://stackoverflow.com/questions/51572110/excel-vba-how-to-copy-multiple-ranges-from-same-sheet