Excel - 将包含空单元格的行移动到另一个工作表

Question

这是我第一次尝试 VBA，所以我为我的无知道歉。情况如下：我有一个由 4 列和 629 行组成的电子表格。当我试图做的是遍历每行中的 4 个单元格并检查一个空白单元格。如果有一行包含空白单元格，我想从 Sheet1 中剪切它并将其粘贴到 Sheet2 中的第一个可用行中。

（理想情况下，列数和行数是基于每个电子表格的动态的，但我不知道如何动态地遍历行和列）

Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'


Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long


Dim Counter As Integer


'Initialize Variables

LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1

'Sheets(Sheet1).Select

'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)

    For Counter = 1 To 4

        If Sheet1.Cells(CurrentRow, Counter).Value = "" Then

            Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
            EmptySheetCount = EmptySheetCount + 1
            Counter = 1
            CurrentRow = CurrentRow + 1
            GoTo BREAK

        Else

            Counter = Counter + 1

        End If

        Counter = 1
BREAK:
    Next

Wend
End Sub

当我运行它时，我通常会在 Sheet1.Cells(CurrentRow, Counter).Value = "" 区域出现错误，所以我知道我错误地引用了工作表。我已经尝试过 Sheets(Sheet1)、Worksheets("Sheet1")，但似乎没有任何效果。但是，当我更改为 Worksheets("Sheet1") 时，它会运行并冻结 Excel。

我知道我做错了很多事情，我只是知道得太少，不知道是什么。

提前非常感谢。并且对于垃圾格式感到抱歉。

Answer 1

您的代码存在一些问题，因此这里不是单独检查它们，而是一个基本的循环版本，可以满足您的需求。

Sub moveData()

    Dim wksData As Worksheet
    Dim wksDestination As Worksheet

    Dim lastColumn As Integer
    Dim lastRow As Integer

    Dim destinationRow As Integer

    Set wksData = Worksheets("Sheet1")
    Set wksDestination = Worksheets("Sheet2")

    destinationRow = 1

    lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
    lastRow = wksData.Range("A1048576").End(xlUp).Row

    For i = lastRow To 1 Step -1    'go 'up' the worksheet to handle 'deletes'
        For j = 1 To lastColumn
            If wksData.Cells(i, j).Value = "" Then      'check for a blank cell in the current row
                'if there is a blank, cut the row
                wksData.Activate
                wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut

                wksDestination.Activate
                wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
                ActiveSheet.Paste

                'If required this code will delete the 'cut' row
                wksData.Rows(i).Delete shift:=xlUp

                'increment the output row
                destinationRow = destinationRow + 1

                Exit For     'no need to carry on with this loop as a blank was already found
            End If
        Next j
    Next i

    set wksData = Nothing
    set wksDestination = Nothing

End Sub

还有其他方法可以达到相同的结果，但这应该让您了解如何使用loops、sheets、ranges 等。

lastColumn 和 lastRow 变量将在给定的列/行中找到最后一列/行数据（即，在我的代码中，它找到行 1 中的最后一列数据，最后一个A 列中的一行数据）。

此外，您应该养成调试和单步调试代码的习惯，以识别错误并准确查看每一行的内容（这也有助于您学习）。

Answer 2

您可能会发现这很有用。 它使用一个数组变量来存储要移动的行中单元格的值。它不使用剪切和粘贴，因此只传输数据值，并且代码不需要激活所需的工作表。 目标行与原始工作表上的行顺序相同。 用于查找行和列中使用的最后一个单元格的方法比给出的其他答案更优雅。

Option Explicit

Public Sub test_moveData()

    Dim wksData As Worksheet
    Dim wksDestination As Worksheet

    Set wksData = shtSheet1         ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
    Set wksDestination = shtSheet2

    moveData wksData, wksDestination

End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)

    Dim ilastColumn As Integer
    Dim ilastRow As Integer
    Dim iRow As Long
    Dim iColumn As Long
    Dim iDestinationRowNumber As Integer

    Dim MyArray() As Variant
    Dim rngRowsToDelete As Range


    iDestinationRowNumber = 1

    ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
    ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row

    ReDim MyArray(1, ilastColumn)
    Set rngRowsToDelete = Nothing

    For iRow = 1 To ilastRow Step 1     'No need to go 'up' the worksheet to handle 'deletes'

        For iColumn = 1 To ilastColumn

            If wksData.Cells(iRow, iColumn).Value = "" Then        'check for a blank cell in the current row

                MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value

                    wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
                     wksDestination.Cells(iDestinationRowNumber, ilastColumn) _ 
                                        ).Value = MyArray

                'Store the rows to be deleted
                If rngRowsToDelete Is Nothing Then
                    Set rngRowsToDelete = wksData.Rows(iRow)
                Else
                    Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
                End If

                'increment the output row
                iDestinationRowNumber = iDestinationRowNumber + 1

                Exit For     'no need to carry on with this loop as a blank was already found
            End If

        Next iColumn

    Next iRow

    If Not rngRowsToDelete Is Nothing Then
        rngRowsToDelete.EntireRow.Delete shift:=xlUp
    End If
    Set rngRowsToDelete = Nothing

    Set wksData = Nothing
    Set wksDestination = Nothing

End Sub

'享受