Add "Filter out Blanks" to current code:

[rmoran4446]

So this code will take the active workbook, save each sheets "VALUES" to a new workbook. However, if there are values on Row 1056 in the master "book" there will not be any value in the "NEW SAVED WORKBOOK" until Row 1056.

Therefore, upon saving the new workbook, I need to have that new workbook sorted to sort out the blank values.

Thank you in advance for any help

The current Code:

Sub Copy_Every_Sheet_To_New_Workbook()'Working in 97-2013
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With


    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook


    'Create new folder to save the new files in
    DateString = Format(Now, "mm-dd-yyyy")
    FolderName = Sourcewb.Path & "/" & "DeanPay" & " " & DateString
    MkDir FolderName


    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets


        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy


            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook


            
            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells.PasteSpecial xlPasteFormats
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If




            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "/" & Destwb.Sheets(1).Name & " " & DateString & ".xls"
                .Close False
            End With


        End If
GoToNextSheet:
    Next sh


    MsgBox "You can find the files in " & FolderName


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

 

[Stubble Kid]

Try the modified code below, which will filter out any blank rows and delete them. The filter criteria assumes a "blank" row is one with nothing in cols 1,2, and 3, and this may need adjustment if it is too simplistic for your data. Row 1 will be untouched (as it's needed for the filtering process).

    'Change all cells in the worksheet to values if you want
    If Destwb.Sheets(1).ProtectContents = False Then
        With Destwb.Sheets(1).UsedRange
            .Cells.Copy
            .Cells.PasteSpecial xlPasteValues
            .Cells.PasteSpecial xlPasteFormats
            '*****************************************
            ' filter out blank rows...
            .Rows.Select
            With Selection
                .AutoFilter
                .AutoFilter Field:=1, Criteria1:="="
                .AutoFilter Field:=2, Criteria1:="="
                .AutoFilter Field:=3, Criteria1:="="
                .Offset(1).Delete Shift:=xlUp
                .AutoFilter
            End With
            ' *****************************************
            .Cells(1).Select
        End With
        Application.CutCopyMode = False
    End If

 

[rmoran4446]

That worked PERFECTLY! Thank you very much!