从Recordset删除空白行并修复Add_Total()合计行异常问题

• 工作表通过下拉选择输出数据，数据最多3行，实际可能为1行或2行，但目前始终输出3行（包含空行），需检测并删除空行
• 当Recordset中的行数少于3行时，Add_Total()子过程无法将合计值输出到正确位置

原代码 #

Private Sub dateBox_Change()


        Dim connection As New ADODB.connection, dttime1, dttime2, dttime3

        connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
        ";Extended Properties=""Excel 12.0;HDR=YES;"";"

        Dim dateQuery As String
        Dim queryString As String
        Dim cptString1 As String
        Dim cptString2 As String
        Dim cptString3 As String
        Dim date1 As String
        Dim date2 As String
        Dim date3 As String
        Dim datetime1 As Date
        Dim datetime2 As Date
        Dim datetime3 As Date 

        dateQuery = Me.dateBox.Text

        cptString1 = "00:30"
        cptString2 = "01:30"
        cptString3 = "02:00"
        
        
        date1 = dateQuery
        date2 = dateQuery
        date3 = dateQuery
        
        datetime1 = (DateValue(date1) + TimeValue(cptString1))
        datetime2 = (DateValue(date2) + TimeValue(cptString2))
        datetime3 = (DateValue(date3) + TimeValue(cptString3))
        
        dttime1 = 1 * (datetime1)
        dttime2 = 1 * (datetime2)
        dttime3 = 1 * (datetime3)


        queryString = "Select [Lane],[Containerized Packages],[Staged Packages],[Loaded Packages],[Staged Packages]+[Containerized Packages]+[Loaded Packages]  as TotalProcessed,[Departed Packages]," & _
        "[Expected Packages],[All Packages],[Expected Packages] + [All Packages] - [TotalProcessed] as Remaining,[Departed Packages] + [Expected Packages] + [All Packages] as TotalVolume from [Data$] where [CPTs]*1 =" & dttime1 & "or [CPTs] *1 =" & dttime2 & "or [CPTs] *1 =" & dttime3
         
        
        
        Dim rs As New ADODB.Recordset
        rs.Open queryString, connection
        


        Dim rSht As Worksheet
        Set rSht = ThisWorkbook.Worksheets("Sheet1")

        With rSht

        .Cells.ClearContents
        For i = 0 To rs.Fields.Count - 1
        .Cells(4, i + 1).Value = rs.Fields(i).Name
        Next i
        .Range("A5").CopyFromRecordset rs

        End With
        
        Call Add_Total

        connection.Close
End Sub


Public Sub Add_Total()

    Dim ColumnNumber As Long
    Dim LastRow As Long

    With ThisWorkbook.Worksheets("Sheet1")
        For ColumnNumber = 5 To 10
            LastRow = .Cells(.Rows.Count, ColumnNumber).End(xlUp).Row
            With .Cells(LastRow + 1, ColumnNumber)
                .FormulaR1C1 = "=SUM(R2C:R[-1]C)"
            End With
        Next ColumnNumber
    End With

End Sub

问题截图 #

• ![3行数据（包含空行）]
• ![2行数据（合计行位置错误）]

修改后完整代码 #

Private Sub dateBox_Change()
    Dim connection As New ADODB.connection, dttime1, dttime2, dttime3

    connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
    ";Extended Properties=""Excel 12.0;HDR=YES;"";"

    Dim dateQuery As String
    Dim queryString As String
    Dim cptString1 As String
    Dim cptString2 As String
    Dim cptString3 As String
    Dim date1 As String
    Dim date2 As String
    Dim date3 As String
    Dim datetime1 As Date
    Dim datetime2 As Date
    Dim datetime3 As Date 

    dateQuery = Me.dateBox.Text

    cptString1 = "00:30"
    cptString2 = "01:30"
    cptString3 = "02:00"
    
    date1 = dateQuery
    date2 = dateQuery
    date3 = dateQuery
    
    datetime1 = (DateValue(date1) + TimeValue(cptString1))
    datetime2 = (DateValue(date2) + TimeValue(cptString2))
    datetime3 = (DateValue(date3) + TimeValue(cptString3))
    
    dttime1 = 1 * (datetime1)
    dttime2 = 1 * (datetime2)
    dttime3 = 1 * (datetime3)

    queryString = "Select [Lane],[Containerized Packages],[Staged Packages],[Loaded Packages],[Staged Packages]+[Containerized Packages]+[Loaded Packages]  as TotalProcessed,[Departed Packages]," & _
    "[Expected Packages],[All Packages],[Expected Packages] + [All Packages] - [TotalProcessed] as Remaining,[Departed Packages] + [Expected Packages] + [All Packages] as TotalVolume from [Data$] where [CPTs]*1 =" & dttime1 & "or [CPTs] *1 =" & dttime2 & "or [CPTs] *1 =" & dttime3
         
    
    Dim rs As New ADODB.Recordset
    rs.Open queryString, connection

    Dim rSht As Worksheet
    Set rSht = ThisWorkbook.Worksheets("Sheet1")

    With rSht
        .Cells.ClearContents
        '写入标题行
        For i = 0 To rs.Fields.Count - 1
            .Cells(4, i + 1).Value = rs.Fields(i).Name
        Next i
        '写入数据
        .Range("A5").CopyFromRecordset rs
        
        '删除空行：倒序遍历避免删行后索引错乱
        Dim lastDataRow As Long
        lastDataRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        If lastDataRow >= 5 Then
            Dim rowNum As Long
            For rowNum = lastDataRow To 5 Step -1
                If Application.WorksheetFunction.CountA(.Rows(rowNum)) = 0 Then
                    .Rows(rowNum).Delete
                End If
            Next rowNum
        End If
    End With
    
    Call Add_Total

    connection.Close
End Sub


Public Sub Add_Total()
    Dim ColumnNumber As Long
    Dim LastRow As Long
    Dim dataStartRow As Long: dataStartRow = 5 '数据起始行固定为第5行

    With ThisWorkbook.Worksheets("Sheet1")
        '基于Lane列（A列）获取数据最后一行，确保准确性
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        '仅当存在数据行时添加合计
        If LastRow >= dataStartRow Then
            For ColumnNumber = 2 To 10 '从数值列开始计算合计
                With .Cells(LastRow + 1, ColumnNumber)
                    '求和范围限定在数据行内，避免包含标题
                    .FormulaR1C1 = "=SUM(R" & dataStartRow & "C:R" & LastRow & "C)"
                    .Font.Bold = True '可选：合计行加粗
                End With
            Next ColumnNumber
            '给合计行添加标识
            .Cells(LastRow + 1, 1).Value = "合计"
            .Cells(LastRow + 1, 1).Font.Bold = True
        End If
    End With
End Sub

修改说明 #

1. 删除空行：在写入数据后，倒序遍历数据行，通过CountA判断整行是否为空，为空则删除，避免删行后索引错乱。
2. 修正合计行：
   • 基于非空的Lane列（A列）获取数据最后一行，确保定位准确
   • 求和范围限定在数据起始行（第5行）到最后一行，避免包含标题行
   • 添加"合计"标识并加粗，提升可读性
   • 仅当存在数据行时才生成合计，避免无数据时出现空合计行

内容的提问来源于stack exchange，提问作者F.OLeary