使用vba复制和粘贴大量单元格

Question

我正在尝试制定时间表。为此，我需要复制很多范围并将它们填充在同一张纸的其他位置。有没有一种方法可以清理此代码，使其变得更快且重复性更低？

Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("E19:E25")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("F26:F32")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("G33:G39")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("H40:H46")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("I47:I53")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("J5:J11")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("K12:K18")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("L19:L25")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("M26:M32")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("N33:N39")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("O40:O46")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("P47:P53")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("Q12:Q18")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("R19:R25")
Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range("S26:S32")

Answer 1

您可以将所有“粘贴”范围存储在一个数组中，在其中按每个范围循环并粘贴。参见下文（经过测试）：

Sub CopyPasteUsingArray()

    Dim rRangeArray() As Variant
    Dim wsOU As Worksheet
    Dim i As Long

    Set wsOU = Worksheets("Overordnet ugeplan")

    rRangeArray = Array("E19:E25", "F26:F32")

    wsOU.Range("D12:D18").Copy

    For i = LBound(rRangeArray) To UBound(rRangeArray)
        wsOU.Range(rRangeArray(i)).PasteSpecial Paste:=xlPasteAll
    Next i

    Application.CutCopyMode = False

End Sub

或者，您可以使用类似的方法来设置值，而无需使用复制/粘贴。

Sub SetValuesArray()

    Dim rRangeArray() As Variant
    Dim wsOU As Worksheet
    Dim i As Long

    Set wsOU = Worksheets("Overordnet ugeplan")

    rRangeArray = Array("E19:E25", "F26:F32")

    For i = LBound(rRangeArray) To UBound(rRangeArray)
        wsOU.Range(rRangeArray(i)).Value = wsOU.Range("D12:D18").Value
    Next i

End Sub

Answer 2

另一个例子

function componentToHex(c) {
  var hex = c.toString(16);
  return hex.length == 1 ? "0" + hex : hex;
}

function rgbToHex(r, g, b) {
  return "#" + componentToHex(r) + componentToHex(g) + componentToHex(b);
}
var input = document.querySelectorAll("input");
for (var i = 0; i < input.length; i++) {
  input[i].addEventListener("input", function() {
    var red = document.getElementById("red").value,
      green = document.getElementById("green").value,
      blue = document.getElementById("blue").value;
    var display = document.getElementById("display");
    display.style.color = "rgb(" + red + ", " + green + ", " + blue + ")";
    display.innerHTML = rgbToHex(red , green , blue);
  });
}

Answer 3

只需执行3个循环，具体取决于您在哪里开始和结束。

Dim ZZ As Long 'for rows
Dim YY As Long 'for columns

YY = 0

For ZZ = 19 To 47 Step 7
    Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range(Cells(ZZ, 5 + YY), Cells(ZZ + 6, 5 + YY))
    YY = YY + 1
Next ZZ

For ZZ = 5 To 47 Step 7
    Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range(Cells(ZZ, 5 + YY), Cells(ZZ + 6, 5 + YY))
    YY = YY + 1
Next ZZ

For ZZ = 12 To 26 Step 7
    Worksheets("Overordnet ugeplan").Range("D12:D18").Copy Range(Cells(ZZ, 5 + YY), Cells(ZZ + 6, 5 + YY))
    YY = YY + 1
Next ZZ

我明白了：

Answer 4

修改Teamothy提供的代码可以达到目的：

Sub CopyAndPaste()

Dim i As Long
Dim myRange As Range
Set myRange = Worksheets("Overordnet ugeplan").Range("D12:D18")

With Worksheets("Overordnet ugeplan")

For i = 5 To 19
    If i <= 9 Then
    myRange.Copy .Range(.Cells(19 + 7 * (i - 5), i), .Cells(19 + 6 + 7 * (i - 5), i))
    ElseIf i > 9 And i < 17 Then
    myRange.Copy .Range(.Cells(5 + (7 * (i - 5)) - 35, i), .Cells(5 + 6 + (7 * (i - 5)) - 35, i))
    ElseIf i >= 17 Then
    myRange.Copy .Range(.Cells(5 + (7 * (i - 5)) - 84, i), .Cells(5 + 6 + (7 * (i - 5)) - 84, i))
    End If
Next

End With