Excel VBA：如何从同一工作表复制多个范围

我对VBA很陌生。我有一个表，有多个范围，我想复制和粘贴到新闻电子表格。第一个范围是C2:I37，下一个范围正好从C38:I73下方的36个单元格开始，下一个范围正好从C74:I109下方的36个单元格开始，依此类推。总的来说，我需要复制32个范围，它们都来自同一张纸，并且距离相等

我可以在下面给出的宏中的第一个范围（C2:I37）实现这一点（它做一些与此问题无关的其他事情）。但我不知道如何在剩下的31个范围内有效地做到这一点。任何反馈都将不胜感激

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

---

根据宏修改此循环

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

---

根据宏修改此循环

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

---

可以使用循环结构来实现这一点。我假设您的文件名也是每36个单元格一次，例如，G1，然后是G37，等等。如果不是，那么我们需要做一些轻微的修改

这避免了选择或激活任何内容的需要，并通过直接赋值而不是使用“复制/粘贴”更有效地传输值

（这将为每个复制的区域创建一个新工作簿）

---

可以使用循环结构来实现这一点。我假设您的文件名也是每36个单元格一次，例如，G1，然后是G37，等等。如果不是，那么我们需要做一些轻微的修改

这避免了选择或激活任何内容的需要，并通过直接赋值而不是使用“复制/粘贴”更有效地传输值

（这将为每个复制的区域创建一个新工作簿）

---

一点数学知识会给你范围。假设所有工作都进入一个工作簿，因为我看不到您为工作簿设置任何新名称

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

---

如果要转到不同的工作簿，您需要一些代码来更改文件名，但周围的代码可能是：

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

---

一点数学知识会给你范围。假设所有工作都进入一个工作簿，因为我看不到您为工作簿设置任何新名称

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

---

如果要转到不同的工作簿，您需要一些代码来更改文件名，但周围的代码可能是：

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

---

是否要将32个区域粘贴在单独的32张图纸上或仅粘贴在一张图纸上？是否要将32个区域粘贴在单独的32张图纸上或仅粘贴在一张图纸上？是的，文件名为G1，每36个单元格一次。这个剧本非常适合我，正是我想要的。非常感谢。向上投票；超级使用变量，不使用

复制/粘贴

和使用

偏移量

重置范围变量。但是，

Fiename:=ThisFile

不应该是

Filename:=Filename

？是的，文件名在G1中，每36个单元格一个。这个剧本非常适合我，正是我想要的。非常感谢。向上投票；超级使用变量，不使用

复制/粘贴

和使用

偏移量

重置范围变量。但是，

Fiename:=ThisFile

不应该是

Filename:=Filename

？