如何通过复制和粘贴自动更改数据的维度？

Question

我有一些数据占用了 4 列和 1400 行。每 15 行对应一个不同的城市，在 A 列中命名。例如，第 1-14 行可能是东京，但第 15-28 行可能是多伦多。现在，我们可以忽略 A 列。有什么方法可以自动复制和粘贴剩余的 14 行 3 列块，使它们都显示 side-by-side?

我的最终目标是在每个 14 x 3 块上方放置 header 行由 A 列组成的合并单元格，以便给它们一个标题。但是，我必须首先提取所需的 14 x 3 块。我认为这是 VBA 宏的工作？

例如，我的部分数据如下所示：

Location	Team	Staff	Sales
Toronto	1	1100	55
Toronto	2	2100	56

[...多伦多还有 12 行]

Location	Team	Staff	Sales
Tokyo	21	7100	75
Tokyo	42	3100	16
Tokyo	35	9200	41

等等

到目前为止，我最好的尝试是获取此原始数据并在另一个 sheet 和 =RAW!$B1:$D14 上引用它，然后将该公式向下拖动到数百行，复制结果，然后转置它。这给了我正确的输出，但是每个 14 x 3 的块都被一个 11 x 14 的空单元格块分隔开。我想要它们 side-by-side.

Answer 1

请测试下一个代码。它在下一个 sheet 中使用数组及其切片数组和 returns。您可以选择所需的任何目的地 sheet。如果你按原样测试，你必须确保另一个 sheet 存在于 active 之后（待处理）并且它是空的：

Sub CopySlicesOf15()
  Dim sh As Worksheet, shDest As Worksheet, lastR As Long, arr, arrSlice, arrH, arrA
  Dim cellInit As Range, iPaste As Long, lastArrR As Long, i As Long, k As Long
  
  Set sh = ActiveSheet  'use here the sheet to be processed
  Set shDest = sh.Next  'use here the sheet where to return the processed result
  Set cellInit = shDest.Range("A2")     'the cell where to start pasting the slice arrays from
  lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'you use 1400 instead if you like that...
  arrA = sh.Range("A1:A" & lastR).value 'place the range in an array for faster iteration
  arr = sh.Range("B1:D" & lastR).value  'place the rang in an aray, for faster iteration and slicijg
  ReDim arrH(Int(lastR / 15) + 1)       'redim the array keeping the future headers
  For i = 1 To UBound(arr) Step 15      'iterate between the main array in steps of 15 rows:
        arrH(k) = arrA(i, 1): k = k + 1 'place the appropriate header in the headers array
        If i > (UBound(arr) - 15) Then
            lastArrR = i + (UBound(arr) - i)  'the slice numbere of rows for the last slice
        Else
            lastArrR = i + 14                 'until the last slice, the slice numbere of rows will be 15
        End If
        'extract the necessary slice array:
        arrSlice = Application.Index(arr, Evaluate("row(" & i & ":" & lastArrR & ")"), Evaluate("column(A:C)"))
        'drop the array content at once in the appropriate cells:
        shDest.Range("A2").Offset(0, iPaste).Resize(IIf(UBound(arr) = i, 1, UBound(arrSlice)), 3).value = arrSlice: iPaste = iPaste + 3
  Next i
  
  iPaste = 1                                  'reinitialize the variable
  For i = 1 To UBound(arrH)                   'iterate between the headers array
    shDest.cells(1, iPaste).value = arrH(i)   'place the header name in the cell
    'merge cells and center:
    With shDest.Range(shDest.cells(1, iPaste), shDest.cells(1, iPaste).Offset(0, 2))
        .merge
        .HorizontalAlignment = xlCenter
    End With
    iPaste = iPaste + 3 ' increment the variable for next cell to paste the header
  Next
End Sub

如何通过复制和粘贴自动更改数据的维度？

How can I automatically change the dimensions of my data by copy and pasting?

excel

vba

copy-paste