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

我有一个约63张工作簿。 我想从所有的工作表中采取所有过滤的数据（由macros过滤），并将其粘贴到一个单独的工作表。

工作表不具有相同的数据范围。 他们都将从第15行开始，如果有任何数据的话。 筛选器macros筛选其中一列中的特定值，从而区分每个工作表中的行。

我需要复制从范围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给你过滤的数据。

为了帮助debugging你的代码，设置一个断点并使用立即窗口来查看范围是什么，即：

 ?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 (ie 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