Excel VBA：如何从同一个 sheet 复制多个范围

Question

我是 VBA 的新手。我有一个 sheet，它有多个范围，我想将其复制并粘贴到新闻传播 sheet 中。第一个范围是 C2:I37，下一个范围从 C38:I73 下方正好 36 个单元格开始，下一个范围从 C74:I109 下方正好 36 个单元格开始，依此类推。我总共需要复制 32 个范围，它们都来自同一个 sheet，并且距离相等。

我可以在下面给出的宏中为第一个范围 (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

Answer 1

根据您的宏修改此循环。

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

Answer 2

您可以使用循环结构来完成此操作。我假设你的文件名也是每 36 个单元格，例如 G1，然后是 G37，等等。如果不是，那么我们需要做一些小的修改。

这避免了 Select 或 Activate 任何东西的需要，并且通过直接分配而不是使用 Copy/PasteSpecial

更有效地传递值

（这会为每个复制的范围创建一个新工作簿）

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

Answer 3

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

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

Excel VBA：如何从同一个 sheet 复制多个范围

Excel VBA: How to copy multiple ranges from same sheet

excel

vba

copy-paste

excel-2016