将表格行从一张纸剪切到另一张纸

Question

我在两张纸上有两个 Excel 表格：“打开”和“保留或关闭”。

在“打开”表上，如果填充了“CLOSED_DATE”列记录，我尝试在表内剪切一行并将其粘贴到“保留或关闭”表中。如果未填充，则不会发生任何事情。

我的代码在第一次迭代中成功，但如果我再次运行它，我会得到一个旋转轮，这导致我的工作簿在第二次迭代时关闭而没有错误消息。

这是我的代码，可能存在无限循环。

Sub CutPasteRows()
    Dim sourceTable As ListObject
    Dim newTable As ListObject
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim Count As Integer
    Dim i As Long
    Dim ii As Long

    Set sourceTable = Worksheets("Open").ListObjects("Current_Ops_TBL8")
    Set newTable = Worksheets("Hold or Closed").ListObjects("Hold_Closed_TBL3")
    Set targetTable = Worksheets("Hold or Closed")
    Count = 4
    ii = sourceTable.Range.Rows.Count
    
    Debug.Print (sourceTable.ListColumns("IAA CLOSED DATE").DataBodyRange.Rows.Count())
    
    For Each iListRow In sourceTable.ListColumns("IAA CLOSED DATE").DataBodyRange.Rows
        Debug.Print (iListRow)
        If iListRow.Value <> "" Then
            Debug.Print (iListRow.Value)
            Worksheets("Open").Rows(Count).Copy
            targetTable.Rows("2").Insert
            Worksheets("Open").Rows(Count).Clear
        End If
        Count = Count + 1
    Next iListRow

End Sub

我希望每次在“CLOSED_DATE”列中插入日期并选择运行宏时，“打开”工作表行都会粘贴到“保留或关闭”工作表中。 “打开”工作表行将变为空白。

Answer 1

导出数据：将 Excel 表格行移动到另一个 Excel 表格

之前

之后

Sub ExportClosedData()
    ' Write the title of the procedure to a constant variable to be used
    ' as the title of all message boxes that may be displayed to the user,
    ' to make it easy to identify which procedure the message box is related to.
    Const PROC_TITLE As String = "Export Closed Data"
    
    ' Turn off screen updating to speed up the code execution.
    Application.ScreenUpdating = False
        
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source: Reference the Range
    
    ' Reference the source worksheet and table.
    Dim sws As Worksheet: Set sws = wb.Sheets("Open")
    Dim slo As ListObject: Set slo = sws.ListObjects("Current_Ops_TBL8")
    
    ' Clear active filters.
    With slo
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
    End With
    
    ' Reference the source range (no headers).
    Dim srg As Range: Set srg = slo.DataBodyRange

    ' Check if there is any data in the source table, and if there is none,
    ' display an error message and exit.
    If srg Is Nothing Then
        MsgBox "No data in the source table.", vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    ' Store the column index of the criteria column in a variable.
    Dim sCol As Long: sCol = slo.ListColumns("IAA CLOSED DATE").Index
    
    ' Destination: Reference the First Row Range
    
    ' Reference the destination worksheet and table.
    Dim dws As Worksheet: Set dws = wb.Sheets("Hold or Closed")
    Dim dlo As ListObject: Set dlo = dws.ListObjects("Hold_Closed_TBL3")
    
    ' Clear active filters.
    With dlo
        If .ShowAutoFilter Then
            If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
        End If
    End With
    
    ' Attempt to reference the destination table's data range.
    Dim drg As Range: Set drg = dlo.DataBodyRange
    
    ' Reference the first destination data row.
    If drg Is Nothing Then dlo.ListRows.Add ' no data in table
    Set drg = dlo.DataBodyRange.Rows(1)
   
    ' Copy, insert and paste, and combine to finally delete.
    
    Dim surg As Range, srrg As Range, rCount As Long
    
    ' For each row in the source table...
    For Each srrg In srg.Rows
        ' ... check if the value in the criteria column is not blank.
        If Len(CStr(srrg.Cells(sCol).Value)) > 0 Then ' is not blank
            ' Insert a new row in the destination table.
            drg.Insert xlShiftDown, xlFormatFromLeftOrAbove
            ' Correct the destination row.
            Set drg = drg.Offset(-1)
            ' Copy the data from the source row to the destination row.
            srrg.Copy drg
            ' Combine the source row into a unioned range.
            If surg Is Nothing Then
                Set surg = srrg
            Else
                Set surg = Union(surg, srrg)
            End If
            ' Increment the counter used to display the final count
            ' in a message box.
            rCount = rCount + 1
        'Else ' the value is blank; do nothing
        End If
    Next srrg
    
    ' Delete the source rows in one go, if any.
    If rCount > 0 Then surg.Delete xlShiftUp
    
    ' Turn screen updating back on.
    Application.ScreenUpdating = True
    
    ' Inform.
    
    ' Display a message indicating how many rows of 'closed' data were exported,
    ' or a warning message if there is no 'closed' data to export.
    If rCount > 0 Then
        MsgBox rCount & " record" & IIf(rCount = 1, "", "s") _
            & " of closed data exported.", vbInformation, PROC_TITLE
    Else
        MsgBox "No closed data. Nothing to export.", vbExclamation, PROC_TITLE
    End If

End Sub