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

我有一个循环，改变复制单元格和粘贴单元格的范围。 这是与select – 但导致代码运行缓慢。 我怎样才能改善这个不使用select？

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

昏暗的lastcell长

 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

你的复制和粘贴应该是类似的东西。 所有这些select都会显着减慢一切。

  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点等间隔

我为这种情况testing过的代码：

 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

尽pipe他的代码产生了与您提供的结果不同的结果，但是亚行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 

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