代码中粘贴内容时出错
我试图做出以下代码，以复制几行的内容将其内容复制到第二行。
Sub PasteBetter() Dim r As Range, cell As Range Dim rng As Range Set r = Range(Range("A3"), Range("A3").End(xlDown)) For Each cell In r Range(Selection, Selection.End(xlToRight)).Select Application.CutCopyMode = False Selection.Cut Set rng = Range(Range("A2"), Selection.End(xlToRight)) Range(rng).Offset(RowOffSet:=1).Select ActiveSheet.Paste Next cell End Sub 然而，这挂在范围（rng）.Offset（RowOffSet：= 1）。select线，说它错过了一个全球性的变种。 被调用的唯一一个是在它之前的行中定义的rng。 我在这里编码错误是什么？
至于澄清，我正在试图做一个像这样的文件
看起来像这样 
rng已经是一个范围。 无需将其包装到Range()方法中。 所以，这应该解决它：
rng.Offset(RowOffSet:=1).Select
但是，您可能需要在此修改您的代码：
Set r = Range(Range("A3"), Range("A3").End(xlDown))
像这样（如果可能的话）：
Set r = Range(Range("A3"), Cells(Rows.Count, "A").End(xlUp))
否则，可能会发生范围将下降到该表（Excel 2007+超过一百万）的最后一行，你的sub将运行相当一段时间…
更新1：
虽然上面解决了原始代码，但下面的代码是应该完成的改进版本。
Option Explicit Sub PasteBetter() Dim varArray As Variant Dim strFinalarray() As String Dim lngLastRow As Long, lngLastColumn As Long Dim lngColumn As Long, lngRow As Long ReDim strFinalarray(0) With ThisWorkbook.Worksheets(1) lngLastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lngLastColumn = .Cells.Find("*", SearchOrder:=xlColumns, SearchDirection:=xlPrevious).Column varArray = .Range(Range("A2"), Cells(lngLastRow, lngLastColumn)).Value2 For lngRow = LBound(varArray) To UBound(varArray) For lngColumn = 1 To lngLastColumn If varArray(lngRow, lngColumn) <> vbNullString Then strFinalarray(UBound(strFinalarray)) = Trim(varArray(lngRow, lngColumn)) ReDim Preserve strFinalarray(UBound(strFinalarray) + 1) End If Next lngColumn Next lngRow ReDim Preserve strFinalarray(UBound(strFinalarray) - 1) .Range(.Cells(2, 1), Cells(2, UBound(strFinalarray) + 1)).Value2 = strFinalarray .Range(.Cells(3, 1), .Cells(lngLastRow, lngLastColumn)).ClearContents End With End Sub
上面的代码应该是非常快的（几乎是瞬间的）。 这是由于访问表被限制在最低限度。 访问表单的人越多（从表单读取数据或将数据写入表单）代码越慢。 在上面的代码中，所有数据都是用一行代码varArray = .Range(Range("A2"), Cells(lngLastRow, lngLastColumn)).Value2 。
在这一点上varArray几乎是工作表的复制（从A2开始）。 然后将这个数组中的所有东西移动到另一个（1维）数组中，最后粘贴到以单元格A2开始的表单上。
更新2：
Sub SimpleVersion() Dim lngRow As Long Dim lngColumn As Long Dim lngCopyToColumn As Long Dim lngLastRow As Long Dim lngLastColumn As Long With ThisWorkbook.Worksheets(1) 'Get the last row and last column for the sheet 'Source: http://www.thespreadsheetguru.com/blog/2014/7/7/5-different-ways-to-find-the-last-row-or-last-column-using-vba lngLastRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lngLastColumn = .Cells.Find("*", SearchOrder:=xlColumns, SearchDirection:=xlPrevious).Column 'Loop through all rows and all columns lngCopyToColumn = lngLastColumn + 1 For lngRow = 3 To lngLastRow For lngColumn = 1 To lngLastColumn 'If the cell is not empty then... If .Cells(lngRow, lngColumn).Value2 <> vbNullString Then 'Copy the cell over to the end .Cells(2, lngCopyToColumn).Value2 = .Cells(lngRow, lngColumn).Value2 'Increase lngCopyToColumn by 1. Otherwise, ' the same cell gets overwritten over and over again lngCopyToColumn = lngCopyToColumn + 1 End If Next lngColumn Next lngRow 'Not that everything is copied over ' everything below row 2 can get deleted .Range(.Cells(3, 1), .Cells(lngLastRow, lngLastColumn)).ClearContents End With End Sub
这个解决scheme可能会更容易理解。 不要犹豫，问你是否有理解它的问题。
不要打扰复制和粘贴…尝试下面
Sub asdf() Dim a As Worksheet Dim b As Worksheet Set a = Sheets("Sheet2") 'replace with your source sheet Set b = Sheets("Sheet3") 'replace with your destination sheet For c = 1 To a.Range("iv1").End(xlToLeft).Column 'find last column lastrow = a.Cells(65536, c).End(xlUp).Row 'find last row b.Range(b.Cells(1, c), b.Cells(lastrow, c)).Value = a.Range(a.Cells(1, c), a.Cells(lastrow, c)).Value Next c End Sub
编辑
我原来的回答并没有解决这个问题。 更新如下：
Sub asdf() Dim a As Worksheet Dim b As Worksheet Set a = Sheets("Sheet2") 'replace with your source sheet Set b = Sheets("Sheet3") 'replace with your destination sheet For r = 3 To a.Range("a65536").End(xlUp).Row 'find last row lastCol = a.Range("iv2").End(xlToLeft).Offset(0, 1).Column 'get last column in destination row lastCol2 = a.Cells(r, 16383).End(xlToLeft).Column 'get last column in copy row a.Range(a.Cells(r, 1), a.Cells(r, lastCol2)).Copy a.Cells(2, lastCol).PasteSpecial a.Range(a.Cells(r, 1), a.Cells(r, lastCol2)).ClearContents Next r End Sub
这是另一个不依赖于剪切和粘贴的解决scheme：
更新：
我不得不使范围更大来粘贴数组的所有值。 见下文。 谢谢你让我知道！ 我希望这个已经解决了你:)
Option Compare Binary Public Sub MoveCellsOneRow() Dim LastRow As Long Dim myrow As Long Dim LastColumn As Integer Dim mycol As Integer Dim StartCol As Integer Dim MyArray() As Variant Dim ArrayCounter As Long LastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row StartCol = Cells(2, Columns.Count).End(xlToLeft).Column + 1 ArrayCounter = 0 'Determine what the size of the array should be For myrow = 3 To LastRow LoopColumns = Cells(myrow, Columns.Count).End(xlToLeft).Column + 1 For mycol = 1 To LoopColumns If Cells(myrow, mycol) <> vbNullString Then ArrayCounter = ArrayCounter + 1 Next mycol Next myrow 'Resize the array once, redim preserve is an expensive operation ReDim MyArray(0 To ArrayCounter) ArrayCounter = 0 'Populate the array. code below is almost identical to previous solution For myrow = 3 To LastRow LastColumn = Cells(2, Columns.Count).End(xlToLeft).Column LoopColumns = Cells(myrow, Columns.Count).End(xlToLeft).Column + 1 For mycol = 1 To LoopColumns If Cells(myrow, mycol) <> vbNullString Then MyArray(ArrayCounter) = Cells(myrow, mycol) ArrayCounter = ArrayCounter + 1 End If Next mycol Next myrow 'Dump the array contents, and clear the other cells 'Made a change here to correct for the 'paste' range. Needed to be wider Range(Cells(2, (Cells(2, Columns.Count).End(xlToLeft).Column + 1)), Cells(2, (ArrayCounter + StartCol))) = MyArray() Range(Cells(3, 1), Cells(LastRow, (Cells(2, Columns.Count).End(xlToLeft).Column + 1))) = "" End Sub