VBA不粘贴到表中的空行

Question

我的目标是将符合特定条件的行复制并粘贴到另一个工作簿的表中。

我的 VBA 运行良好，只是它粘贴在表格下方的空单元格中。不在表格内标题下方的空单元格中。

PS。我知道使用 select 通常不受欢迎，但我需要使用相当基本的语法，以便如果下一个人需要修改它并且不熟悉 VBA，他们可以。

Sub Export()

Sheets("Export Format").Select

Cells(13, "D").Calculate

        With Range("A1", Cells(Rows.Count, "L").End(xlUp))  'reference its column A:G cells from row 1 (header) down to last not empty one in column "A"
            
            .AutoFilter Field:=6, Criteria1:="<>0" ' filter referenced cells on 6th column with everything but "0" content
            
            If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then
                
                .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy ' copy filtered cells skipping headers
                
                With Workbooks.Open(Filename:="Z:\Tracking\Database.xlsx").Sheets("Sheet1") 'open wanted workbook and reference its wanted sheet
                    
                    .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone _
                    , SkipBlanks:=False, Transpose:=False 'paste filtered cells in referenced sheet from ist column A first empty cell after last not empty one
                    
                    .Parent.Close True 'Save and closes referenced workbook
                
                End With
                
                Application.CutCopyMode = False
            
            End If
        
        End With
        
        On Error Resume Next
        Sheets("Export Format").ShowAllData 'Clears Filters
        On Error GoTo 0
        
        Sheets("Export Format").Select 'Brings back to Main request sheet
    
End Sub

Answer 1

尝试使用表的属性，例如InsertRowRange

Sub Export()

    Const DBFILE = "Z:\Tracking\Database.xlsx"
    Dim wb As Workbook, wbDB As Workbook
    Dim ws As Worksheet, tbl As ListObject
    Dim rngFilter As Range, x, rng As Range

    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Export Format")
    
    x = Application.WorksheetFunction.Subtotal(103, ws.Columns(1))
    If x <= 1 Then
        ws.Select
        Exit Sub
    End If

    ' set filter range
    With ws
       .Range("D13").Calculate
       ' column A:L cells from row 1 (header)
       ' down to last not empty one in column "A"
       Set rngFilter = .Range("A1", .Cells(Rows.Count, "L").End(xlUp))
    End With
    
    ' open wanted workbook and reference its wanted sheet
    Set wbDB = Workbooks.Open(DBFILE)
    With wbDB.Sheets("Sheet1")
        Set tbl = .ListObjects("Table1")
        If tbl.InsertRowRange Is Nothing Then
           Set rng = tbl.ListRows.Add.Range
        Else
           Set rng = tbl.InsertRowRange
        End If
    End With

    ' filter on 6th column with everything but "0" content
    With rngFilter

        .AutoFilter Field:=6, Criteria1:="<>0"
        ' copy filtered cells skipping headers
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
        'paste filtered cells in referenced sheet
        'from ist column A first empty cell after last not empty one
        rng.PasteSpecial Paste:=xlPasteValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
       
    End With

    wbDB.Close True 'Save and closes referenced workbook
    ws.AutoFilterMode = False
    ws.Select 'Brings back to Main request sheet
    MsgBox "Ended"
  
End Sub