运行时错误1004：对象范围的方法偏移在VBA循环中失败

我想要做的是循环通过列Afind空白单元格，并复制该行中的最后一个单元格之后的上一行中的行B和C列中的两个数字。 然后删除列A中的空白行。

这是在执行代码之前的空白单元格的图像：

第二张图片显示了我的代码的结果：

Sub PivotTableLayout() Dim rng As Range 'Dim row As Range Dim cell As Range Set rng = ThisWorkbook.Sheets("CopyPivot").Columns("A") For Each cell In rng.Rows If IsEmpty(cell) Then ' Do while is blank Do While IsEmpty(cell) 'offset one right and copy two cells ActiveCell.Offset(0, 1).Resize(1, 2).Copy ' offset counter and 1 up ActiveCell.Offset(-1, 0).End(xlToRight).Offset(0, 1).Select ActiveSheet.Paste ActiveCell.Offset(1, 0).Select ActiveCell.EntireRow.Delete Loop End If Next cell End Sub 

但是，我不断收到运行时错误1004在这一行，但它的工作原理，如果我从代码中删除它…我无法弄清楚为什么：

 ActiveCell.Offset(-1, 0).End(xlToRight).Offset(0, 1).Select 

Answer 1

当你删除行 （或列）时，最好从下到上 （或从右到左）循环。 下面的代码会给你想要的结果。

 Sub PivotTableLayout() Dim i As Long Dim lastRow As Long, lastColumn As Long lastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = lastRow To 1 Step -1 If Cells(i, 1).Value = "" Then lastColumn = Cells(i - 1, Columns.Count).End(xlToLeft).Column Range("B" & i, Range("B" & i).End(xlToRight)).Copy Cells(i - 1, lastColumn + 1) Rows(i).Delete End If Next End Sub 

编辑： ___________________________________________________________________________

 Sub PivotTableLayout2() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim i As Long Dim lastRow As Long, lastColumn As Long lastRow = Cells(Rows.Count, "A").End(xlUp).Row For i = lastRow To 1 Step -1 If Cells(i, 1).Value = "" Then lastColumn = Cells(i - 1, Columns.Count).End(xlToLeft).Column Range(Cells(i, 2), Cells(i, Cells(i, Columns.Count).End(xlToLeft).Column)).Copy Cells(i - 1, lastColumn + 1) Rows(i).Delete End If Next Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = False End Sub 

Answer 2

你也可以使用函数specialcells：

 Sub remove() Dim rFirstColumn As Range Set rFirstColumn = Worksheets("Sheet2").Columns("A") Dim rBlanks As Range Set rBlanks = rFirstColumn.SpecialCells(xlCellTypeBlanks) Dim iBlanks As Integer iBlanks = rBlanks.Count Dim iCount As Integer For iCount = 1 To iBlanks Step -1 Set rPrevious = rBlanks.Cells(iCount, 1).Offset(-1, Columns.Count - 1).End(xlToLeft) Range("B" & rBlanks.Cells(iCount, 1).Row, Range("B" & rBlanks.Cells(iCount, 1).Row).End(xlToRight)).Copy rPrevious.Offset(0, 1) Rows(rBlanks.Cells(iCount, 1).Row).Delete Next iCount End Sub 

Answer 3

使用两行@Mrig解决scheme，并解决一些细节。 这个解决scheme只能看到空单元格。

 'more efficient ...just work with empty cells Sub PivotTableLayout3() Dim i As Long Dim aux As Object Dim lastRow As Long, lastColumn As Long Sheets("CopyPivot").Select lastRow = Cells(Rows.Count, "A").End(xlUp).Row i = Cells(1, 1).End(xlDown).Row + 1 'first empty cell While (i < lastRow) While IsEmpty(Cells(i, 1)) And i < lastRow 'working with empty cells Set aux = Range("B" & i).End(xlToRight) If Not aux.Column = 16384 Then 'not empty row lastColumn = Cells(i - 1, Columns.Count).End(xlToLeft).Column Range("B" & i, Range("B" & i).End(xlToRight)).Copy Cells(i - 1, lastColumn + 1) End If Rows(i).Delete lastRow = lastRow - 1 'my last row has changed Wend i = Cells(i, 1).End(xlDown).Row + 1 'next empty cell Wend End Sub