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

:cheers:

[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