Question

请告诉我如何更改我的代码，只有在BC列中有值时才选择行（如果BC列中的单元格为空，则忽略完整行）：

Private Sub CommandButton3_Click()
    Range("A:a,b:b,c:c,e:e,bc:bc").Select
    Selection.Copy
    Workbooks.Add          
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=True, Transpose:=False
End Sub

Answer 1

首先按原样运行代码。然后在添加的工作簿中执行行删除：

Sub dural()
    Dim N As Long, I As Long, r As Range
    N = Cells(Rows.Count, "BC").End(xlUp).Row
    For I = N To 1 Step -1
        Set r = Cells(I, "BC")
        If IsEmpty(r) Then
            r.EntireRow.Delete
        End If
    Next
End Sub

Answer 2

您可以使用过滤器执行此操作：

通过取消选中（空白）
复制列
粘贴到新工作表或工作簿

如果必须是VBA，这里有两个代码可以按要求执行。第一个代码使用autofilter：

Private Sub CommandButton3_Click()

    Dim wsData As Worksheet
    Dim wsNew As Worksheet

    Set wsData = ActiveSheet
    Set wsNew = Sheets.Add

    With Intersect(wsData.UsedRange, wsData.Columns("BC"))
        .Parent.AutoFilterMode = False
        .AutoFilter 1, "<>"
        Intersect(.SpecialCells(xlCellTypeVisible).EntireRow, wsData.Range("A:A,B:B,C:C,E:E,BC:BC")).Copy
        wsNew.Range("A1").PasteSpecial xlPasteValues
        wsNew.Range("A1").PasteSpecial xlPasteFormats
        .AutoFilter
    End With

    wsNew.Move

    Set wsData = Nothing
    Set wsNew = Nothing

End Sub

第二个替代代码使用了一个find循环：

Private Sub CommandButton3_Click()

    Dim rngFound As Range
    Dim rngCopy As Range
    Dim strFirst As String

    Set rngFound = Columns("BC").Find("*", Cells(Rows.Count, "BC"), xlValues, xlWhole)
    If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Set rngCopy = rngFound
        Do
            Set rngCopy = Union(rngCopy, rngFound)
            Set rngFound = Columns("BC").Find("*", rngFound, xlValues, xlWhole)
        Loop While rngFound.Address <> strFirst
    End If

    If Not rngCopy Is Nothing Then
        Sheets.Add
        Intersect(rngCopy.Parent.Range("A:A,B:B,C:C,E:E,BC:BC"), rngCopy.EntireRow).Copy
        Range("A1").PasteSpecial xlPasteValues
        Range("A1").PasteSpecial xlPasteFormats
        ActiveSheet.Move
    End If

    Set rngFound = Nothing
    Set rngCopy = Nothing

End Sub

在特定列中跳过包含空白单元格的行

2 个答案: