Page 1 of 2 12 LastLast
Results 1 to 15 of 19
  1. #1
    5 Star Lounger
    Join Date
    Jan 2001
    Location
    La Jolla,CA
    Posts
    1,074
    Thanks
    12
    Thanked 36 Times in 35 Posts

    Filter, select, copy, paste

    I have a workbook with 26 sheets. I want to filter each sheet for non-blanks using column I, select the filtered results from columns I - P, inclusive, do a copy then do a paste special values only in another workbook, starting in column A, with the respective sheets named the same as the original workbook. The original 26 sheets have varying numbers of rows.

    A bit laborious one-by-one, so I thought one of you VBA magicians would have a slick approach.

  2. Get our unique weekly Newsletter with tips and techniques, how to's and critical updates on Windows 7, Windows 8, Windows XP, Firefox, Internet Explorer, Google, etc. Join our 480,000 subscribers!

    Excel 2013: The Missing Manual

    + Get this BONUS — free!

    Get the most of Excel! Learn about new features, basics of creating a new spreadsheet and using the infamous Ribbon in the first chapter of Excel 2013: The Missing Manual - Subscribe and download Chapter 1 for free!

  3. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    6,175
    Thanks
    200
    Thanked 781 Times in 715 Posts
    Kevin,

    This should do the trick.
    Code:
    Sub CopyFiltered()
    
       Dim wkbSource As Workbook
       Dim wkbDest   As Workbook
       Dim sht       As Worksheet
       
       Application.ScreenUpdating = False
       Set wkbSource = ActiveWorkbook
       Set wkbDest = Workbooks("Destination.xlsx")
       
       For Each sht In wkbSource.Sheets
       
          'Select Data
          sht.Activate
          
           Range("A1").Select
           Range(Selection, Selection.End(xlDown)).Select
           Range(Selection, Selection.End(xlToRight)).Select
        
          'Set Up AutoFilter & Copy
          Selection.AutoFilter
          Range("$A$1:$P$17").AutoFilter Field:=9, Criteria1:="<>"
          Columns("I:P").Select
          Selection.Copy
          
          'Move to Destination workbook and sheet
          wkbDest.Activate
          Sheets(sht.Name).Activate
          
          'Paste data in
          [A1].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
              :=False, Transpose:=False
          [A1].Select
          
          'Return to source and clean up
          wkbSource.Activate
          Application.CutCopyMode = False
          Selection.AutoFilter
          [A1].Select
        
       Next sht
       
    End Sub   'CopyFiltered
    Note: The code assumes that both the Source and Destination workbooks are open and that both have the same number of sheets and the sheets have the same names!

    Note 2: Place the code in the Source workbook and start with it active.

    Note 3: Change this line Set wkbDest = Workbooks("Destination.xlsx") to reflect the name of your destination workbook.

    HTH
    May the Forces of good computing be with you!

    RG

    VBA Rules!

    My Systems: Desktop Specs
    Laptop Specs


  4. #3
    5 Star Lounger
    Join Date
    Jan 2001
    Location
    La Jolla,CA
    Posts
    1,074
    Thanks
    12
    Thanked 36 Times in 35 Posts
    Thanks, RG. After 45 minutes, I stopped it and it had only progress through slightly less than half of the sheets (12 of 26).

    Whew. Where's the bottleneck? In 45 min, I think I could have done it fully one at a time, no?

  5. #4
    5 Star Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,196
    Thanks
    45
    Thanked 227 Times in 210 Posts
    RG,

    What if you were to modify your code to "Save as" the workbook first, filter each sheet, delete the hidden rows, and then delete columns A thru H? I'll bet it would be be much faster than copy and pasting from workbook to workbook.

  6. #5
    5 Star Lounger
    Join Date
    Jan 2001
    Location
    La Jolla,CA
    Posts
    1,074
    Thanks
    12
    Thanked 36 Times in 35 Posts
    Maudibe...that's what I did manually. Once I got into the rhythm, it moved along quickly. Whew. It's done.

  7. #6
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    6,175
    Thanks
    200
    Thanked 781 Times in 715 Posts
    Kevin,

    Guess I'm just too slow!

    I couldn't figure out how to get Maud's solution into code but I came up with a close second using some of his idea.
    Code:
    Option Explicit
    
    Sub SortThenDelete()
       
       Dim lFirstRow   As Long
       Dim lLastRow    As Long
       Dim lCurRow     As Long
       Dim sht         As Worksheet
       
       Application.ScreenUpdating = False
       
       ActiveWorkbook.SaveAs Filename:="G:\BEKDocs\Excel\Destination2.xlsm", _
             FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    
       For Each sht In ActiveWorkbook.Sheets
    
          sht.Activate
          lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
          lFirstRow = 0
          Range("A1").Select
          Range(Selection, Selection.End(xlDown)).Select
          Range(Selection, Selection.End(xlToRight)).Select
           
          With ActiveSheet.Sort
              .SortFields.Clear
              .SortFields.Add Key:=Range("I1:I" & Format(lLastRow)) _
                , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
              .SetRange Range("A1:P" & Format(lLastRow))
              .Header = xlGuess
              .MatchCase = False
              .Orientation = xlTopToBottom
              .SortMethod = xlPinYin
              .Apply
          End With  'ActiveSheet
    
          Cells(lLastRow, 1).Select
        
         For lCurRow = lLastRow To 1 Step -1 'loop through all rows
            If Cells(lCurRow, 9).Value = "" Then
              'Rows(lCurRow).EntireRow.Delete
            Else
              lFirstRow = lCurRow
              Exit For
            End If
         Next
       
         If lFirstRow <> lLastRow Then
           Range(Cells(lFirstRow, 1), Cells(lLastRow, 1)).EntireRow.Delete
         End If
       
         '*** Code to resort sheet here if necessary! ***
         
         Range(Cells(1, 1), Cells(1, 8)).EntireColumn.Delete
         
       Next sht
       
    End Sub
    The code will sort the data on Col I then delete the rows with blanks in I and then cols A:H working on a saved copy as Maud suggested. I've indicated where you could put code to resort the data (if that is possible or even desirable).

    Note: change path/file info for destination file in the code before running.

    I know you have it solved but if you have the original workbook I'd very much like to know if this method is faster.
    May the Forces of good computing be with you!

    RG

    VBA Rules!

    My Systems: Desktop Specs
    Laptop Specs


  8. The Following User Says Thank You to RetiredGeek For This Useful Post:

    Maudibe (2014-08-15)

  9. #7
    5 Star Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,196
    Thanks
    45
    Thanked 227 Times in 210 Posts
    Sorting! Brilliant....how obvious it becomes.

  10. #8
    5 Star Lounger
    Join Date
    Jan 2001
    Location
    La Jolla,CA
    Posts
    1,074
    Thanks
    12
    Thanked 36 Times in 35 Posts
    RG. That was pretty fast but it didn't do a paste special values, so the resulting sheet was filled with #REF! errors. And, the column headers vanished - probably because you sorted everything.

    Not sure how to fix that.
    Last edited by kweaver; 2014-08-16 at 08:35.

  11. #9
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    6,175
    Thanks
    200
    Thanked 781 Times in 715 Posts
    Kevin,

    Sorry, forgot that little detail.

    Revised code:
    Code:
    Option Explicit
    
    Sub SortThenDelete()
       
       Dim lFirstRow   As Long
       Dim lLastRow    As Long
       Dim lCurRow     As Long
       Dim sht         As Worksheet
       
       Application.ScreenUpdating = False
       
       ActiveWorkbook.SaveAs Filename:="G:\BEKDocs\Excel\Destination2.xlsm", _
             FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    
       For Each sht In ActiveWorkbook.Sheets
    
          sht.Activate
          lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
          lFirstRow = 0
          Range("A1").Select
          Range(Selection, Selection.End(xlDown)).Select
          Range(Selection, Selection.End(xlToRight)).Select
           
          With ActiveSheet.Sort
              .SortFields.Clear
              .SortFields.Add Key:=Range("I1:I" & Format(lLastRow)) _
                , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
              .SetRange Range("A1:P" & Format(lLastRow))
              .Header = xlGuess
              .MatchCase = False
              .Orientation = xlTopToBottom
              .SortMethod = xlPinYin
              .Apply
          End With  'ActiveSheet
    
          Cells(lLastRow, 1).Select
        
         For lCurRow = lLastRow To 1 Step -1 'loop through all rows
            If Cells(lCurRow, 9).Value = "" Then
              'Rows(lCurRow).EntireRow.Delete
            Else
              lFirstRow = lCurRow
              Exit For
            End If
         Next
       
         If lFirstRow <> lLastRow Then
           Range(Cells(lFirstRow, 1), Cells(lLastRow, 1)).EntireRow.Delete
         End If
       
         '*** Code to resort sheet here if necessary! ***
         
         '*** Copy/Paste Values ***
         Range(Cells(1, 9), Cells(lFirstRow, 16)).Select
         Selection.Copy
         Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                 :=False, Transpose:=False
         Application.CutCopyMode = False
    
         
          Range(Cells(1, 1), Cells(1, 8)).EntireColumn.Delete
          [A1].Select
         
       Next sht
       
    End Sub
    HTH
    May the Forces of good computing be with you!

    RG

    VBA Rules!

    My Systems: Desktop Specs
    Laptop Specs


  12. #10
    5 Star Lounger
    Join Date
    Jan 2001
    Location
    La Jolla,CA
    Posts
    1,074
    Thanks
    12
    Thanked 36 Times in 35 Posts
    Still lost the header row.

    Also, some very strange results, too...a lot of blank rows with data before and after them (on all sheets).

    Also, a few sheets still had formulas that used deleted columns and again resulted in #REF! errors.

  13. #11
    5 Star Lounger
    Join Date
    Jan 2001
    Location
    La Jolla,CA
    Posts
    1,074
    Thanks
    12
    Thanked 36 Times in 35 Posts
    Got an error on yours, Maud....

    'DELETE ROWS WITH SPACE IN COLUMN 9
    For I = LastRow To 1 Step -1
    If .Cells(I, 9).Value = "" Then
    .Rows(I).EntireRow.Delete
    End If
    Next

  14. #12
    5 Star Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,196
    Thanks
    45
    Thanked 227 Times in 210 Posts
    Deleted my post to yield to RG then found that KW responded.

    KW, I don't know why you would be getting an error on that liine

    Here is the code I posed above
    Code:
    Sub FilterFormat()
        Application.ScreenUpdating = False
    '-------------------------------
    'DECLARE AND SET VARIABLES
        Dim LastRow As Integer
        Dim sht As Integer
        Dim I As Integer
    '-------------------------------
    'CREATE WORKING COPY
        ActiveWorkbook.SaveAs Filename:=CurDir & "\" & "Destination2.xlsm", _
           FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    '-------------------------------
    'CYCLE THRU SHEETS
        For sht = 1 To Worksheets.Count
            With Worksheets(sht)
            .Activate
            LastRow = .Cells(Rows.Count, 9).End(xlUp).Row
    '-------------------------------
    'DELETE ROWS WITH SPACE IN COLUMN 9
            For I = LastRow To 1 Step -1
                If .Cells(I, 9).Value = "" Then
                    .Rows(I).EntireRow.Delete
                End If
            Next
    '-------------------------------
    'MOVE DATA TO COLUMN 1
            .Columns("A:G").Delete Shift:=xlToLeft
            End With
        Next sht
        Application.ScreenUpdating = False
    End Sub

  15. #13
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    6,175
    Thanks
    200
    Thanked 781 Times in 715 Posts
    Kevin,

    Don't know which code you used that lost the header but if it was mine you can change .header = xlGuess to .header = xlYes in the sort section.

    HTH
    May the Forces of good computing be with you!

    RG

    VBA Rules!

    My Systems: Desktop Specs
    Laptop Specs


  16. #14
    5 Star Lounger
    Join Date
    Jan 2001
    Location
    La Jolla,CA
    Posts
    1,074
    Thanks
    12
    Thanked 36 Times in 35 Posts
    That chg solved that problem, but FYI -- I'm still getting large gaps of blank rows with data above and below. Weird.

  17. #15
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    6,175
    Thanks
    200
    Thanked 781 Times in 715 Posts
    Kevin,

    Any chance you can upload a workbook?
    May the Forces of good computing be with you!

    RG

    VBA Rules!

    My Systems: Desktop Specs
    Laptop Specs


Page 1 of 2 12 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •