需要從Excel表中刪除空行，然后調整表的大小-使用VBA

Question

我寫了一個宏（主要是通過記錄它）來復制一張紙上某個部分的數據，然后在另一張紙上計算表的末尾並粘貼（特殊粘貼，因為我粘貼的數據是公式，我需要粘貼）值）到表末尾的數據，這本身就增加了表的大小。 這樣可行。

我的問題是我不確定要復制的原始數據范圍中實際有多少值（有一個公式為其賦值或“”），所以我要范圍，以防萬一

所以....粘貼后，我想遍歷表並刪除添加的所有行，這些行只有空字符串（“”）並且沒有值，然后調整表的大小，使其僅與有數據的行。 這些行可以在我粘貼的數據的中間或結尾。 我需要有關VBA代碼的幫助。

我可能還需要清除表格自動添加到其他行中的格式，這里是我到目前為止的代碼

Range("O7:R30").Select    
Selection.Copy
Sheets("deposits").Select
Dim lastRow As Long
lastRow = ActiveSheet.ListObjects("deposits").Range.Rows.Count
Range("A" & lastRow).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Answer 1

最好只將有效的數據放入表中，而不要在粘貼后進行清理。

像這樣

Sub Demo()
    Dim rDest As Range
    Dim lo As ListObject
    Dim wsSrc As Worksheet
    Dim rSrc As Variant
    Dim i As Long
    Dim rng As Range

    'there are better ways to get a reference to the source data, but thats not the Q here
    Set wsSrc = ActiveSheet
    Set rSrc = wsSrc.Range("O7:R30")

    ' destination sheet
    With Sheets("deposits")
        'get reference to table
        Set lo = .ListObjects("deposits")

        'Get reference to first row after the table
        Set rDest = lo.DataBodyRange.Rows(lo.DataBodyRange.Rows.Count + 1)

        i = 0
        'loop thru source data rows
        For Each rng In rSrc.Rows
            'if a row has data
            If Application.WorksheetFunction.CountA(rng) > 0 Then
                'copy values into table
                rDest.Offset(i).Value = rng.Value
                i = i + 1
            End If
        Next
    End With
End Sub

Answer 2

這段代碼有效，雖然不好用，但是有效

Sub copyToDeposits()

Dim theSheet As String
theSheet = ActiveSheet.Name
Application.ScreenUpdating = False
Range("O7:R30").Select
Selection.Copy
Sheets("deposits").Select
Dim lastRow As Long
lastRow = ActiveSheet.ListObjects("deposits").Range.Rows.Count
Range("A" & lastRow).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Dim lo As ListObject
Dim lRow As ListRow
Dim rng As Range
Dim delRows As Collection

Set lo = ActiveSheet.ListObjects("deposits") 'change to your table name
On Error Resume Next
For Each lRow In lo.ListRows
    Set rng = Nothing
    Set rng = lRow.Range.Cells(1, 2)
    If Not rng Is Nothing Then
        If rng = "" Then
            If delRows Is Nothing Then
                Set delRows = New Collection
                delRows.Add lRow
            Else
                delRows.Add lRow, Before:=1
            End If
        End If
    End If
Next
On Error GoTo 0

If Not delRows Is Nothing Then
    For Each lRow In delRows
        lRow.Delete
    Next
End If
Sheets(theSheet).Select
Application.ScreenUpdating = True

結束子