Excel VBA 循环粘贴变量范围并将其复制到变量范围

Excel VBA to loop and copy paste on variable ranges to variable ranges

提问by user2997192

I have a loop which changes the ranges of the copy cells and the paste cells. This is working with Select - but is causing the code to run slowly. How can I improve this to not use the Select?

我有一个循环，它改变了复制单元格和粘贴单元格的范围。这适用于 Select - 但导致代码运行缓慢。我该如何改进以不使用 Select？

    Dim i As Long
Dim x As Long
Dim y As Long

Dim lastcell As Long

将最后一个单元调暗至长

Dim countnonblank As Integer, myrange As Range
Set myrange = Sheets("Label Create Worksheet").Columns("A:A")
countnonblank = Application.WorksheetFunction.CountA(myrange)

lastcell = Int(countnonblank / 9) + 1

For x = 0 To lastcell

i = i + 1

y = y + IIf(x = 0, 0, 9)




Sheets("Label Create Worksheet").Select
Range(Cells(2 + y, 1), Cells(2 + y, 6)).Select
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 1).Select
ActiveSheet.Paste


Sheets("Label Create Worksheet").Select
Range(Cells(3 + y, 1), Cells(3 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 11).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(4 + y, 1), Cells(4 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 21).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(5 + y, 1), Cells(5 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 31).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(6 + y, 1), Cells(6 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 41).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(7 + y, 1), Cells(7 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 51).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(8 + y, 1), Cells(8 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 61).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(9 + y, 1), Cells(9 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 71).Select
ActiveSheet.Paste

Sheets("Label Create Worksheet").Select
Range(Cells(10 + y, 1), Cells(10 + y, 6)).Select
Application.CutCopyMode = False
Selection.Copy

Sheets("Data").Select
Cells(1 + i, 81).Select
ActiveSheet.Paste

Next x

下一个

Set myrange = Nothing

设置 myrange = 无

回答by Tylor Hess

Your copy and paste should be something similar to this. All of those selects slow everything down significantly.

您的复制和粘贴应该与此类似。所有这些选择都会显着减慢一切。

        Sheets("Label Create Worksheet").Range(Cells(2 + y, 1), Cells(2 + y, 10)).Copy

        Sheets("Data").Cells(1 + i, 1).PasteSpecial Paste:=xlPasteValues

回答by user2997192

Many thanks. Got the answer below in case anybody else needs it:

非常感谢。得到以下答案，以防其他人需要它：

Dim i As Long, x As Long, y As Long, lastcell As Long, countnonblank As Long

Dim myrange As Range, wsLCW As Worksheet, wsDAT As Worksheet



Set wsLCW = Sheets("Label Create Worksheet")

Set wsDAT = Sheets("Data")



With wsLCW

    Set myrange = .Columns("A:A")

    countnonblank = Application.CountA(myrange)

    lastcell = Int(countnonblank / 9) + 1

    For x = 0 To lastcell

        i = i + 1

        y = y + IIf(x = 0, 0, 9)



        .Cells(2 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 1)

        .Cells(3 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 11)

        .Cells(4 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 21)

        .Cells(5 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 31)

        .Cells(6 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 41)

        .Cells(7 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 51)

        .Cells(8 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 61)

        .Cells(9 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 71)

        .Cells(10 + y, 1).Resize(, 10).Copy Destination:=wsDAT.Cells(1 + i, 81)

    Next x

End With



Set myrange = Nothing

Set wsLCW = Nothing

Set wsDAT = Nothing

回答by Alex P

Looking at your code it appears that your data in Label Create Worksheetis in columns A to F and you want to place it in sheet Dataon row 2 and spaced out at points 1, 11, 21 etc.

查看您的代码，您的数据似乎Label Create Worksheet位于 A 列到 F 列中，您希望将其Data放在第 2 行的工作表中，并在第 1、11、21 点等处隔开。

This code I tested and worked for that scenario:

我测试并为该场景工作的这段代码：

Sub ReadWriteData()
    Dim data As Range, arr(), rows As Integer, rw As Integer, col As Integer, startPos As Integer

    Set data = Worksheets("Label Create Worksheet").Range("A2:F" & Range("A2").End(xlDown).Row)
    arr() = data

    With Worksheets("Data")
        For rw = 1 To data.rows.Count
            For col = 1 To data.Columns.Count
                .Cells(2, startPos + col) = data(rw, col)
            Next col
            startPos = startPos + (rw * 10)
        Next rw
    End With
End Sub

回答by Instant Breakfast

@Alex P's idea for using a more efficient loop structure is a good one, though his code produces a different result than that provided by you. I adapted his idea to your need, and I think the following code does what you are doing with yours but a little more efficiently.

@Alex P 使用更有效的循环结构的想法是一个很好的想法，尽管他的代码产生的结果与您提供的结果不同。我根据您的需要调整了他的想法，我认为以下代码可以完成您正在使用的代码，但效率更高。

Sub ReadWriteData2()

'~~>Dim variables and set initial values
    Worksheets("Label Create Worksheet").Activate
    Dim rngDataSource As Range
        Set rngDataSource = Worksheets("Label Create Worksheet").Range(Cells(2, 1), _
                                Cells(Range("A2").End(xlDown).Row, _
                                Range("A2").End(xlToRight).Column))
    Dim intSourceRow As Integer
    Dim intSourceColumn As Integer
    Dim intPasteRow As Integer
        intPasteRow = 2
    Dim intPasteColumn As Integer
        intPasteColumn = 1
    Dim intTotalRows As Integer
        intTotalRows = rngDataSource.rows.Count

'~~>Loop to transfer data

    With Worksheets("Data")
        For intSourceRow = 1 To intTotalRows
            If intPasteColumn > 81 Then intPasteColumn = 1
            For intSourceColumn = 1 To 10
                .Cells(intPasteRow, (intPasteColumn + intSourceColumn) - 1).value = _
                 rngDataSource(intSourceRow, intSourceColumn).value
            Next intSourceColumn
            intPasteColumn = intPasteColumn + 10
            intPasteRow = 2 + (Int(intSourceRow / 9))
        Next intSourceRow
    End With
End Sub

Using the timer function to test both, I found this code completes the task about four times faster than yours (I used the new code you posted as an answer to coding the task without the .selectphrases). If your data set will end up being very large, or if you are still having slow performance, you might want to use something similar

使用计时器功能对两者进行测试，我发现此代码完成任务的速度比您的快四倍（我使用您发布的新代码作为对没有.select短语的任务进行编码的答案）。如果您的数据集最终会非常大，或者您的性能仍然很慢，您可能需要使用类似的东西