VBA To Create A New Workbook

[cdurfey]

I need a vba code to create a new workbook and then copy over only the rows that have a "Y" in column K. I need this to save as "CPC Weekend Work" with the current date. Can anyone help? Thanks

[LalitPandey87]

Try this code and change sheet name accordingly:

Sub lm()


    Dim wbkNew              As Workbook
    Dim strFileName         As String
    Dim rngRange            As Range
    Dim rngTemp             As Range
    Dim rngFirst            As Range
    Dim lngCount            As Long
    
    strFileName = "CPC_Weekend_Work_" & Format(Now(), "DD-MMM-YYYY") & ".XLSX"
    strFileName = ThisWorkbook.Path & Application.PathSeparator & strFileName
    With ThisWorkbook.Worksheets("Sheet1")
        Set rngRange = .Range("K1")
        Set rngRange = .Range(rngRange, .Cells(.Rows.Count, rngRange.Column).End(xlUp))
    End With
    Set wbkNew = Workbooks.Add
    With wbkNew.Worksheets("Sheet1")
        With rngRange
            lngCount = 0
            Set rngTemp = .Find("Y", LookIn:=xlValues, LookAt:=xlWhole)
            If Not rngTemp Is Nothing Then
                Set rngFirst = rngTemp
                Do
                    .Range("A1").Offset(lngCount).Value = rngTemp.Value
                    lngCount = lngCount + 1
                    Set rngTemp = .FindNext(rngTemp)
                Loop While Not rngTemp Is Nothing And rngTemp.Address <> rngTemp.Address
            End If
        End With
        .SaveAs strFileName
        .Close
    End With
    
    Set wbkNew = Nothing
    strFileName = vbNullString
    Set rngRange = Nothing
    Set rngTemp = Nothing
    Set rngFirst = Nothing
    lngCount = Empty
    
End Sub

[cdurfey]

I am getting an error on this line

With ThisWorkbook.Worksheets("Sheet1")

[Excel Fox]

As mentioned by Lalit, you should correct the name of the sheet you use in the code. In your post above, it is Sheet1

[cdurfey]

Can you show me just the portion of code that will bring over the entire row if I have a "Y" in column K? I do have other cells that will also have a "Y" in them so I need this to be specific to column K. Thanks

[Excel Fox]

    With ThisWorkbook.Worksheets("Sheet1")
        Set rngRange = .Range("K1")
        Set rngRange = .Range(rngRange, .Cells(.Rows.Count, rngRange.Column).End(xlUp))
    End With

does exactly target column K

[cdurfey]

For some reason it will create a new workbook but it will not bring any information over. Can you help? I need it to bring over the 1st row completely since it has the column titles and then any row below that has a "Y" is column K. Thanks

[Excel Fox]

Try an alternative

Sub TrimWorkbook()

    Dim colLetter As String, SavePath As String
    Dim lastValue As String
    Dim wb As Workbook
    Dim lng As Long
    Dim currentRow As Long
    colLetter = "K"
    SavePath = ThisWorkbook.Path
    'Sort the workbook.
    With ThisWorkbook.Worksheets(1)
        .Cells.AutoFilter field:=.Cells(1, colLetter).Column, Criteria1:="Y"
        lng = .Cells(.Rows.Count, colLetter).End(xlUp).Row
        Set wb = Application.Workbooks.Add(xlWorksheet)
        .Rows(1 & ":" & lng).Copy wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp)
        wb.SaveAs SavePath & "\" & "CPC_Weekend_Work_" & Format(Now(), "DD-MMM-YYYY"), 51
        wb.Close
        .AutoFilterMode = False
    End With
    
End Sub

[cdurfey]

Works perfect. Thanks

[LalitPandey87]

Try this revised version with save new workbook correction:

Sub lm()

    Dim wbkNew              As Workbook
    Dim strFileName         As String
    Dim rngRange            As Range
    Dim rngTemp             As Range
    Dim rngFirst            As Range
    Dim lngCount            As Long
    
    strFileName = "CPC_Weekend_Work_" & Format(Now(), "DD-MMM-YYYY") & ".XLSX"
    strFileName = ThisWorkbook.Path & Application.PathSeparator & strFileName
    With ThisWorkbook.Worksheets("Sheet1")
        Set rngRange = .Range("K1")
        Set rngRange = .Range(rngRange, .Cells(.Rows.Count, rngRange.Column).End(xlUp))
    End With
    Set wbkNew = Workbooks.Add
    With wbkNew
        With .Worksheets("Sheet1")
            With rngRange
                lngCount = 0
                Set rngTemp = .Find("Y", LookIn:=xlValues, LookAt:=xlWhole)
                If Not rngTemp Is Nothing Then
                    Set rngFirst = rngTemp
                    Do
                        .Range("A1").Offset(lngCount).Value = rngTemp.Value
                        lngCount = lngCount + 1
                        Set rngTemp = .FindNext(rngTemp)
                    Loop While Not rngTemp Is Nothing And rngTemp.Address <> rngTemp.Address
                End If
            End With
        End With
        .SaveAs strFileName, 51
        .Close
    End With
    
    Set wbkNew = Nothing
    strFileName = vbNullString
    Set rngRange = Nothing
    Set rngTemp = Nothing
    Set rngFirst = Nothing
    lngCount = Empty
    
End Sub