粘贴内容的代码错误
Error in code to paste contents
我尝试编写以下代码，以便将几行的内容复制到第二行。
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).Select 行，说它错过了一个全局变体。唯一被调用的是 rng，它在它之前的行中定义。我的编码错误是什么？
为了澄清，我正在尝试制作这样的文件
看起来像这样
不要为复制和粘贴而烦恼...试试下面的方法
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
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))
否则，范围可能会下降到 sheet 的最后一行（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
上面的代码应该非常快（几乎是瞬时的）。这是因为对 sheet 的访问被限制在最低限度。访问 sheet 的次数越多（从 sheet 读取数据或向 sheet 写入数据）代码越慢。在上面的代码中，使用一行代码 varArray = .Range(Range("A2"), Cells(lngLastRow, lngLastColumn)).Value2.
将所有数据读入内存
此时 varArray 几乎是 sheet 的复制（从 A2 开始）。然后将此数组中的所有内容移动到另一个（一维）数组中，该数组最终粘贴到以单元格 A2.
开头的 sheet
更新 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
这个解决方案可能更容易理解一些。如果您对它的理解有任何疑问，请不要犹豫。
这是另一个不依赖剪切和粘贴的解决方案：
更新：
我不得不扩大范围以粘贴数组的所有值。见下文。谢谢你让我知道这件事！我希望这个问题已经为您解决了:)
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
我尝试编写以下代码，以便将几行的内容复制到第二行。
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).Select 行，说它错过了一个全局变体。唯一被调用的是 rng，它在它之前的行中定义。我的编码错误是什么？
为了澄清，我正在尝试制作这样的文件
看起来像这样
不要为复制和粘贴而烦恼...试试下面的方法
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
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))
否则，范围可能会下降到 sheet 的最后一行（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
上面的代码应该非常快（几乎是瞬时的）。这是因为对 sheet 的访问被限制在最低限度。访问 sheet 的次数越多（从 sheet 读取数据或向 sheet 写入数据）代码越慢。在上面的代码中，使用一行代码 varArray = .Range(Range("A2"), Cells(lngLastRow, lngLastColumn)).Value2.
此时 varArray 几乎是 sheet 的复制（从 A2 开始）。然后将此数组中的所有内容移动到另一个（一维）数组中，该数组最终粘贴到以单元格 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
这个解决方案可能更容易理解一些。如果您对它的理解有任何疑问，请不要犹豫。
这是另一个不依赖剪切和粘贴的解决方案：
更新：
我不得不扩大范围以粘贴数组的所有值。见下文。谢谢你让我知道这件事！我希望这个问题已经为您解决了:)
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