Extract rows to new worksheet and save as new workbook

[dleckie]

Hi all,
Am looking for some help in removing data rows and then saving it to a new workbook.
I have a worksheet and in column X is the value xx-xx-xx-xx-xx-xxx. If the value ends with 000 (3 zeros), extract that row to worksheet 2.
Then in column Y if the words Management or Support (two separate words) are found in a cell under that column, extract that row and append to worksheet 2.
Then save these changes to a new workbook.
Thank you in advance,
Dave

[Tinbendr]

A sample file sure would help out.

[shrivallabha]

This should give you a start. The risk is a row will get claimed in one category because it meets both criteria:

Sub CollectData()
Dim lLastRow As Long
lLastRow = Range("A" & Rows.Count).End(xlUp).Row ' <-Change Column Letter to suit
'Setting up sheet2
Sheet2.Cells.ClearContents
Sheet2.Range("A1").Value = "X Column Values Ending With 000" ' <-Change Sheet Name to suit
'Assuming your data starts at row 2
For i = lLastRow To 2 Step -1
If Right(Range("X" & i).Value, 3) = "000" Then
Range("A" & i).EntireRow.Copy
ActiveSheet.Paste Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Range("A" & i).EntireRow.Delete
End If
Next i
'Checking for the second criteia
Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
"Y Column Values that have Management or Support in them"
'Rechecking LastRow
lLastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = lLastRow To 2 Step -1
If InStr(1, Range("Y" & i).Value, "Management") > 0 Or _
InStr(1, Range("Y" & i).Value, "Support") Then
Range("A" & i).EntireRow.Copy
ActiveSheet.Paste Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Range("A" & i).EntireRow.Delete
End If
Next i
NewBook
End Sub
Sub NewBook()
Dim sName As String
'Setting the filename
sName = ThisWorkbook.Path & "\" & "New_BK_created_on_" & Date$
'Creating a New Book
With Sheet2
.Copy
End With
With ActiveWorkbook
.SaveAs Filename:=sName, FileFormat:=xlWorkbookNormal
.Close
End With
MsgBox "File is created in the current folder!"
End Sub


As David has suggested you should post with a sample and expected results.

[dleckie]

I am very sorry for getting back so late. After reviewing I decided to make a list of requirements and also upload a before and after as suggested.
In the uploaded workbook, sheet 1 is the before and sheet2 is after.
I am using Office 2007.
1) Copy the data from the following columns and paste them into a new workbook.
a. G – EPS Code
b. L – Task Name
c. M – Executive Director
d. N – OIT Initiative Lead
e. P – Project Manager (PM)
2) Column G - All data under the EPS Code column that do not end with 000 and Align All Text Left
3) Column L – All data under Task Name that does not have the text ‘Management and Support’. If the text is found remove the row completely - Align All Text Left
4) Column M – All data under Executive Director - Align All Text Left
5) Column N – All data under OIT Initiative Lead - Align All Text Left
6) Column P – All data under Project Manager (PM) - Align All Text Left

[dleckie]

Thank you Shrivallabha, i tried you code out but I coul dnot get itto work. I am guessing its because I clarifyed some info. I am really sorry. Very new to this.

I tried understanding the code and I changed:

lLastRow = Range("G" & Rows.Count).End(xlUp).Row ' <-Change Column Letter to suit

and also

Sheet2.Range("L" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
"Y Column Values that have Management or Support in them"
'Rechecking LastRow
lLastRow = Range("L" & Rows.Count).End(xlUp).Row

But got errors the error about Compatibility Checker. "The following features in this workbook are not supported by eariler versions of Excel."
Then another message "File is created in the current folder!"
So I did not go any farther.

Thank you.

[shrivallabha]

See if the attached file is what you want.
Sub CompileData()
Dim lLastRow As Long
Dim rCel As Range
lLastRow = Range("G" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'----------------------------------------------
'Setting up sheet2
'----------------------------------------------
Sheet2.Cells.ClearContents
'------------------------------------------------------
'Copying all data from Sheet1 to Sheet3
'------------------------------------------------------
Sheet1.Range("G1").Resize(lLastRow, 10).Copy
ActiveSheet.Paste Destination:=Sheet2.Range("A1")
Application.CutCopyMode = False
With Sheet2
'------------------------------------------------------
'Deleting the hidden columns that were hidden
'------------------------------------------------------
.Columns("C:E").Delete
'------------------------------------------------------
'Cleaning preceding and trailing spaces
'------------------------------------------------------
For Each Cel In .UsedRange
Cel.Value = Trim(Cel.Value)
Next
'------------------------------------------------------
'Deleting all rows where the criteria 2 is met
'------------------------------------------------------
For i = lLastRow To 2 Step -1
If InStr(1, .Range("C" & i).Value, "Management and Support") > 0 Then
.Range("A" & i).EntireRow.Delete
End If
Next i
'------------------------------------------------------
'Combining the rest of the criteria as:
'Col 4, 5, 6 if data is found, retain row even
'if EPS Code ends with 000
'------------------------------------------------------
'Rechecking the current lastrow after deleting the data
lLastRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = lLastRow To 2 Step -1
If Right(.Range("A" & i).Value, 3) = "000" And _
.Range("D" & i).Value & .Range("E" & i).Value & _
.Range("F" & i).Value = "" Then
.Range("A" & i).EntireRow.Delete
End If
Next i
'------------------------------------------------------
'Matching column width
'------------------------------------------------------
.Columns("A").Width = Columns("G").Width
.Columns("B").Width = Columns("H").Width
.Columns("C").Width = Columns("L").Width
.Columns("D").Width = Columns("M").Width
.Columns("E").Width = Columns("N").Width
.Columns("F").Width = Columns("O").Width
.Columns("G").Width = Columns("P").Width
End With
NewBook
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub NewBook()
Application.DisplayAlerts = False
Dim sName As String
'Setting the filename
sName = ThisWorkbook.Path & "\" & "New_BK_created_on_" & Date$
'Creating a New Book
With Sheet2
.Copy
End With
With ActiveWorkbook
.SaveAs Filename:=sName, FileFormat:=xlOpenXMLWorkbook
.Close
End With
MsgBox "File is created in the current folder as:" & vbCr & _
"New_BK_created_on_" & Date$
Application.DisplayAlerts = True
End Sub