CODEWITHSUNDEEP
excelvba
Motorhead1308
Motorhead1308

Reputation: 183

Copy all previously filtered data from all worksheets to another

I have a workbook with about 63 sheets. I'd like to take all filtered data (filtered by a macro) from all worksheets and paste them into a separate worksheet.

Worksheets DON'T have the same data range. They all would start on Column A Row 15 IF there is any data there at all. The filter macro filters for specific values in one of the columns hence the differentiation between rows in each sheet.

I need to copy all filtered data starting with a Range of A15 and the last row in the range would be AI. It's just a matter of how many rows if there are any rows to get the number for the AI in the range to copy over.

I got it to copy an entire sheet, not the filtered data, to another sheet but it only copied sheet 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

Upvotes: 1

Views: 366

Answers (1)

Nic Paul
Nic Paul

Reputation: 31

You can use Worksheet.UsedRange to give you just the Range with data in, then you could apply your Range.SpecialsCells to give you just the filtered data.

To help debug your code, set a breakpoint and use the Immediate Window to see what the range is, i.e.:

?rng.Address

(The question mark prints out whatever follows.)

This function should do what you need:

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

Upvotes: 0

Related Questions