粘贴内容的代码出错

Question

我尝试制作以下代码，以便复制多行的内容，将其内容复制到第二行。

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

但是，这会挂起Range（rng）.Offset（RowOffSet：= 1）。选择行，说它错过了一个全局变体。唯一一个被调用的是rng，它在它之前的行中定义。我的编码错误是什么？

至于澄清，我正在尝试制作这样的文件

看起来像这样

Answer 1

不要打扰复制和粘贴...尝试下面的

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

Answer 2

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

此解决方案可能更容易理解。如果您对此有任何疑问，请随时询问。

Answer 3

这是另一种不依赖剪切和粘贴的解决方案：

<强>更新

我必须使范围更宽以粘贴数组的所有值。见下文。谢谢你告诉我这件事！我希望这个问题已经为你解决了：）

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