Question

我有一张约63页的工作簿。我想从所有工作表中获取所有过滤后的数据（通过宏过滤）并将其粘贴到单独的工作表中。

工作表DON＆T; T具有相同的数据范围。它们都将从A列第15行开始，如果有任何数据的话。过滤器宏过滤其中一列中的特定值，因此区分每张表中的行。

我需要复制以A15范围开头的所有过滤数据，范围中的最后一行是AI。如果有任何行可以获得要复制的范围内AI的数量，那么这只是一个问题。

我让它将整张纸而不是过滤后的数据复制到另一张纸上，但它只复制了纸张1。

Sub rangeToNew_Try2()
Dim newBook As Excel.Workbook
Dim rng As Excel.Range

Set newBook = Workbooks.Add

Set rng = ThisWorkbook.Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeVisible)

rng.Copy newBook.Worksheets("Sheet1").Range("A1")
End Sub

Answer 1

您可以使用Worksheet.UsedRange为您提供包含数据的范围，然后您可以应用Range.SpecialsCells为您提供过滤后的数据。

为了帮助调试代码，设置断点并使用立即窗口查看范围，即：

?rng.Address

（问号打印出以下内容。）

此功能可以满足您的需求：

Sub CopyFilteredDataToNewWorkbook()

    Dim newBook As Excel.Workbook
    Dim rng As Excel.Range
    Dim sht As Excel.Worksheet
    Dim rowoffsetcount As Long
    Dim newsht As Excel.Worksheet

    Set newBook = Workbooks.Add

    ' ThisWorkbook.Worksheets is the same as the Sheets or Worksheets object, but more explicit
    For Each sht In ThisWorkbook.Worksheets

        ' Get the used rows and columns
        Set rng = sht.UsedRange

        ' Offset the range so it starts at row 15
        rowoffsetcount = 15 - rng.Row
        Set rng = rng.Offset(rowoffsetcount)

        ' Check there will be something to copy
        If (rng.Rows.Count - rowoffsetcount > 0) Then

            ' Reduce the number of rows in the range so it ends at the same row
            Set rng = rng.Resize(rng.Rows.Count - rowoffsetcount)

            ' Check that there is a sheet we can copy it to
            On Error Resume Next
            Set newsht = Nothing
            Set newsht = newBook.Worksheets(sht.Index)
            On Error GoTo 0

            ' We have run out of sheets, add another at the end
            If (newsht Is Nothing) Then
                Set newsht = newBook.Sheets.Add(, newBook.Worksheets(newBook.Worksheets.Count))
            End If

            ' Give it the same name
            newsht.Name = sht.Name

            ' Get the range of visible (i.e. unfiltered) rows
            ' (can't do this before the range resize as that doesn't work on disjoint ranges)
            Set rng = rng.SpecialCells(xlCellTypeVisible)

            ' Paste the visible data into the new sheet
            rng.Copy newsht.Range("A1")

        End If

    Next

End Sub

将所有以前过滤的数据从所有工作表复制到另一个工作表

1 个答案: