如果列为空,则过滤失败

时间:2016-02-09 16:20:17

标签: excel excel-vba vba

根据Col C中的条件过滤数据。 copyRng.AutoFilter Field:=3, Criteria1:="<>"

过滤数据被复制到另一张纸上。当至少有一个单元格中包含数据时,它可以正常工作,但如果整个列都是空白,则会复制所有行,但是,它不应复制任何内容。可以做些什么来解决这个问题?谢谢

    Public Sub CopyCLMData()

    Dim ws As Worksheet
    Dim maxCell As Range
    Dim lRowAccess As Long
    Dim lRowThisWS As Long
    Dim lColThisWS As Long
    Dim copyRng As Range, copyRng2 As Range
    Dim startRow As Long
    Dim startCol As Long

    Dim maxXLRows As Long

    startRow = 2
    startCol = 1

Application.EnableEvents = False
Application.ScreenUpdating = False
    'copy header row
    wsAll.Rows(1).Copy
    wsAccess.Rows(1).PasteSpecial xlPasteValues

    'get summary counts only once (outside of the loop)
    maxXLRows = wsAccess.Rows.Count     'total rows available in summary sheet

    'Copy Colon, Lung, and Melanoma data to summary worksheet (Access)
    For Each ws In Worksheets
        If ws.name = WS_COLON Or ws.name = WS_LUNG Or ws.name = WS_MELA Then

            lRowThisWS = ws.Range("A" & Rows.Count).End(xlUp).Row

            Debug.Print lRowThisWS

            lColThisWS = 35

            'If last row >= StartRow, copy the range

                Set copyRng = ws.Range(ws.Cells(startRow - 1, startCol), ws.Cells(lRowThisWS, lColThisWS)) 'data range

                'copyRng.AutoFilter Field:=1, Criteria1:="<>*_QC*"                    'hide QC rows

                copyRng.AutoFilter Field:=3, Criteria1:="<>"                    'hide blank rows in col C


                If copyRng.SpecialCells(xlCellTypeVisible).Count > 1 Then      'if there is any visible data left

                    'copy visible range only
                    Set copyRng = copyRng.SpecialCells(xlCellTypeVisible).Range(copyRng.Cells(startRow, startCol), copyRng.Cells(lRowThisWS, lColThisWS))

                    copyRng.Copy  'copy values and formats

                    With wsAccess.Cells(lRowAccess + 1, "A")
                        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                        '.PasteSpecial Paste:=xlPasteFormats
                        .PasteSpecial Paste:=xlPasteFormulas
                    End With
                End If
                'copyRng.AutoFilter Field:=1
                copyRng.AutoFilter Field:=3
            End If
        End If
    Next
    Application.CutCopyMode = False

    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

0 个答案:

没有答案