时间戳

首页 > 解决方案 > 删除未使用的表格行

excel - 删除未使用的表格行

问题描述

我有一张包含 6 个表格的表格，每个表格使用 B:N 列。B 列包含每张桌子从凌晨 1 点到凌晨 12 点的小时数。我需要删除单元格下方包含单元格 AF2 上特定值的所有行。例如，AF2 包含 5PM。应删除每张表 B 列中下午 5 点以下的所有行。所有桌子都有标题，例如第一张桌子是收银员，第二张桌子是服务员，依此类推。

这是我到目前为止所拥有的：

Set sh = Sheets("report")
valueToFind = sh.Range("AF2").Value

Do
Set Cell1 = sh.Range("B:B").Find(What:=valueToFind, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Cell1 Is Nothing Then Exit Do
Set Cell2 = sh.Range(Cell1.Address & ":B" & sh.UsedRange.Rows.Count).End(xlDown)
    If IsEmpty(Cell1.Offset(1, 0)) Then
        Exit Sub
    Else
        Rows(Cell1.Row & ":" & Cell2.Row).Delete
    End If
Loop

此代码的问题在于，它还删除了单元格 AF2 上指示的时间的行，当它应该向下移动一个单元格然后删除从该行开始向下移动时。

有什么建议么？

标签： excelvba

解决方案

请在尝试此代码之前备份您的书：

阅读代码的注释并根据您的需要进行调整。（注释/取消注释删除先前范围值中的内容的行）

编辑：见下面的两个版本

版本 1

此代码复制源工作表中的值，然后循环遍历表（listobjects）并随着您要查找的时间删除行下方的行

Public Sub CopyTablesDeleteRows()

    ' Declare objects
    Dim mainSheet As Worksheet
    Dim evalSheet As Worksheet

    Dim evalTable As ListObject

    Dim sourceRange As Range
    Dim destinationRange As Range
    Dim filterCell As Range
    Dim foundCell As Range

    ' Declare other variables
    Dim mainSheetName As String
    Dim reportSheetName As String
    Dim sourceRangeAddress As String
    Dim filterCellAddress As String

    ' Adjust these next lines to fit your needs
    mainSheetName = "Main report"
    reportSheetName = "report"
    sourceRangeAddress = "B2:N84"
    filterCellAddress = "AF2"

    Set mainSheet = ThisWorkbook.Worksheets(mainSheetName)
    ' This is the source range where tables are located
    Set sourceRange = mainSheet.Range(sourceRangeAddress)

    Set evalSheet = ThisWorkbook.Worksheets(reportSheetName)
    Set destinationRange = evalSheet.Range(sourceRangeAddress)
    Set filterCell = evalSheet.Range(filterCellAddress)

    ' Delete previous values
    destinationRange.Clear

    ' Copy source range to destination
    sourceRange.Copy destinationRange

    ' Loop through each table in the worksheet
    For Each evalTable In evalSheet.ListObjects

        ' Find the filter cell value in the table's first column (see ListColumns(1) in next line)
        Set foundCell = evalTable.ListColumns(1).DataBodyRange.Find(What:=Format(filterCell.Value, "hh:mm AM/PM"), _
                                                                    LookIn:=xlValues, lookat:=xlWhole, _
                                                                    searchorder:=xlByRows, SearchDirection:=xlNext, _
                                                                    MatchCase:=False, SearchFormat:=False)
        ' If filter cell value is found inside table's column
        If Not foundCell Is Nothing Then

            ' Delete rows from that cell to the last one in table
            evalTable.DataBodyRange.Rows(foundCell.Row - evalTable.HeaderRowRange.Row + 1 & ":" & evalTable.DataBodyRange.Rows.Count).Delete
        End If

    Next evalTable

End Sub

版本 2

此代码适用于复制粘贴值格式（意味着您失去了结构化表格功能），然后根据搜索的时间值查找结束行和开始行，最后删除范围（代码很长，因为您定位 12:00 的方式AM 在表格底部，有些表格没有全天营业时间）

Public Sub DeleteRows()

    Dim reportSheet As Worksheet

    Dim reportSheetName As String
    Dim valueToFindRangeAddr As String
    Dim lookInColumn As String

    Dim valueToFind As Date

    Dim lastRow As Long
    Dim startRow As Long
    Dim endRow As Long

    Dim generalCounter As Long
    Dim counter As Long
    Dim rangeCounter As Long

    Dim deleteRangeRows() As Variant
    Dim rangeRows() As Variant

    reportSheetName = "report"
    valueToFindRangeAddr = "AF2"
    lookInColumn = "B"

    ' Initialize objects
    Set reportSheet = ThisWorkbook.Worksheets(reportSheetName)
    valueToFind = reportSheet.Range(valueToFindRangeAddr).Value2

    ' Get last cell with values in lookInColumn
    lastRow = reportSheet.Cells(reportSheet.Rows.Count, reportSheet.Columns(lookInColumn).Column).End(xlUp).Row

    If Format(valueToFind, "hh:mm AM/PM") = Format(TimeValue("12:00 AM"), "hh:mm AM/PM") Then
        MsgBox "Value to find is last time in tables"
        Exit Sub
    End If

    For generalCounter = lastRow To 1 Step -1

        ReDim Preserve deleteRangeRows(rangeCounter)
        startRow = 0
        endRow = 0

        ' Get row of last cell with time
        For counter = generalCounter To 1 Step -1
            If IsTime(reportSheet.Range(lookInColumn & counter).Value) = True Then
                endRow = counter
                Exit For
            End If
        Next counter

        ' Get row of cell with value to find
        For counter = endRow - 1 To 1 Step -1
            If reportSheet.Range(lookInColumn & counter).Value = valueToFind Then
                startRow = counter + 1
                Exit For
            ElseIf IsTime(reportSheet.Range(lookInColumn & counter).Value) = False Then
                Exit For
            End If
        Next counter

        If startRow > 0 And startRow <= endRow Then
            deleteRangeRows(rangeCounter) = Array(startRow, endRow)
            rangeCounter = rangeCounter + 1
            generalCounter = counter
        Else
            generalCounter = counter + 1
        End If



    Next generalCounter

    ' Delete rows ranges recorded
    For counter = 0 To UBound(deleteRangeRows) - 1

        startRow = deleteRangeRows(counter)(0)
        endRow = deleteRangeRows(counter)(1)

        reportSheet.Rows(startRow & ":" & endRow).Delete

    Next counter

    MsgBox "Finished"

End Sub

' Credits: https://stackoverflow.com/a/52805191/1521579
Function IsTime(Expression As Variant) As Boolean
    If IsDate(Expression) Then
        IsTime = (Int(CSng(CDate(Expression))) = 0)
    End If
End Function

让我知道它是否有效，并记得标记答案以帮助他人

推荐阅读