Move rows to new work book based on a cell value.

[rajesh nag]

Hi,

I have created a macros which transfers data in existing work book.

Here is the sample code.



Option Explicit

Sub DistributeRows()
Dim wsAll As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim LastRow As Long
Dim LastRowCrit As Long
Dim I As Long
Set wsAll = Worksheets("Test")
LastRow = wsAll.Range("A" & Rows.Count).End(xlUp).Row
Set wsCrit = Worksheets.Add
wsCrit.Range("A1") = wsAll.Range("d1")
wsCrit.Range("A2") = "Closed PO"
Set wsNew = Worksheets.Add
wsAll.Range("A1:an" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
Set wsCrit = Worksheets.Add
wsCrit.Range("A1") = wsAll.Range("d1")
wsCrit.Range("A2") = "Open PO"
Set wsNew = Worksheets.Add
wsAll.Range("A1:an" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
Set wsCrit = Worksheets.Add
wsCrit.Range("A1") = wsAll.Range("d1")
wsCrit.Range("A2") = "NEW"
wsCrit.Range("A3") = "New"
wsCrit.Range("A3") = "new"
Set wsNew = Worksheets.Add
wsAll.Range("A1:an" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsCrit.Range("A1:A2"), _
CopyToRange:=wsNew.Range("A1"), Unique:=False
Application.DisplayAlerts = False
wsCrit.Delete
Application.DisplayAlerts = True
End Sub


And i have user form which stores value in IU2 which matches with column "C". My need is once i post the value to IU2 thorugh user form.

Open a work book and transfer the data for the above status into individual sheets and save work book with value in IU2 appending with _report and name the sheets with the above status names.

Regards,
Rajesh.

[rajesh nag]

Finaly I have the macros which full fill my needs

Here are the codes.


Sub CopySheets()
Dim i As Long, s As String
s = ThisWorkbook.Name
If Sheets("Test").Cells(2, 254).Text <> "" Then
Sheets(Array("Test", "Open PO", "Closed PO", "NEW")).Copy
Workbooks(Workbooks.Count).SaveAs _
Filename:="D:\" + Sheets("Test").Cells(2, 254).Text + "_Report.xls", _
FileFormat:=xlNormal, _
Password:="", _
WriteResPassword:="", _
ReadOnlyRecommended:=False, _
CreateBackup:=False
Sheets("test").Delete
ActiveWorkbook.Save
Workbooks(Workbooks.Count).Close
Sheets("Open PO").Delete
Sheets("Closed PO").Delete
Sheets("NEW").Delete
ActiveWorkbook.Save
End If
Windows(s).Activate
End Sub