VBA To Create A New Workbook

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

Try this code and change sheet name accordingly:

Code:

---

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

---

:cheers:

I am getting an error on this line

With ThisWorkbook.Worksheets("Sheet1")

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

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

Code:

---

    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

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

Try an alternative

Code:

---

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

---

Works perfect. Thanks

Try this revised version with save new workbook correction:

Code:

---

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

---