Question

我有一个循环，它改变了复制单元格和粘贴单元格的范围。这与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

下一个x

设置myrange = Nothing

Answer 1

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

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

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

Answer 2

非常感谢。如果有其他人需要，请在下面得到答案：

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

Answer 3

查看代码时，Label Create Worksheet中的数据显示在A到F列中，您希望将其放在第2行的工作表Data中，并在第1,11,21点间隔开来等

我为这种情况测试并运行了这段代码：

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

Answer 4

@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

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

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

4 个答案: