運行時錯誤1004：在VBA循環中的對象範圍失敗的方法

Question

我想要做的是循環通過列A找到空白單元格並複製上面一行中該行的列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解決方案的兩行，解決一些細節。該解決方案只能看到空單元格。

'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