Vba 复制多个范围并粘贴为一个统一范围（在列中）

我在网上搜索了一下，但没有找到与这个问题完全相同的东西。我试图复制一些单独的区域，并将它们粘贴到另一张纸上的一行中。这是我到目前为止所做的

Sub CopyTitle()
  Dim range1 As Range
  Dim range2 As Range
  Dim range3 As Range
  Dim range4 As Range
  Dim range5 As Range
  Dim range6 As Range
  Dim range7 As Range
  Dim range8 As Range
  Dim range9 As Range
  Dim range10 As Range
  Dim range11 As Range
  Dim multipleRange As Range
  Set range1 = Sheets("RAW").Range("B8")
  Set range2 = Sheets("RAW").Range("D9")
  Set range3 = Sheets("RAW").Range("F10")
  Set range4 = Sheets("RAW").Range("F12")
  Set range5 = Sheets("RAW").Range("F14")
  Set range6 = Sheets("RAW").Range("D15")
  Set range7 = Sheets("RAW").Range("F16")
  Set range8 = Sheets("RAW").Range("F18:F21")
  Set range9 = Sheets("RAW").Range("F23:F24")
  Set range10 = Sheets("RAW").Range("F26:F33")
  Set range11 = Sheets("RAW").Range("F35:F40")
  Set multipleRange = Union(range1, range2, range3, range4, range5, range6, range7, range8, range9, range10, range11)
  multipleRange.Copy
  Sheets("RAW").Cells(10, 10).PasteSpecial Transpose:=True
End Sub

---

我在multipleranges.copy上收到一个错误。它表示不能复制多个范围。我能做些什么来实现我的目标？

不能复制一个包含多个区域的范围。您必须一次在一个范围内传输数据。使用

Range.Areas

您可以看到多个区域包含多个多语种。

您可以通过将范围放入一个数组中，然后在数组中循环来获得所需的内容。另外，在测试下面的代码时，我必须设置

Transpose:=False

，才能让它为我工作

Sub CopyTitle()

  Dim rArray(1 To 11) As Range

  Set rArray(1) = Sheets("RAW").Range("B8")
  Set rArray(2) = Sheets("RAW").Range("D9")
  Set rArray(3) = Sheets("RAW").Range("F10")
  Set rArray(4) = Sheets("RAW").Range("F12")
  Set rArray(5) = Sheets("RAW").Range("F14")
  Set rArray(6) = Sheets("RAW").Range("D15")
  Set rArray(7) = Sheets("RAW").Range("F16")
  Set rArray(8) = Sheets("RAW").Range("F18:F21")
  Set rArray(9) = Sheets("RAW").Range("F23:F24")
  Set rArray(10) = Sheets("RAW").Range("F26:F33")
  Set rArray(11) = Sheets("RAW").Range("F35:F40")

  Dim i, j As Integer

  For i = 1 To 11
  rArray(i).Copy
  j = 0
    Do Until Sheets("RAW").Cells(10 + j, 10).Value = "" 'loop down until you reach the next blank cell...
        j = j + 1
    Loop
  Sheets("RAW").Cells(10 + j, 10).PasteSpecial Transpose:=False
  Next

End Sub

---

我正在检查这个！