PDA

View Full Version : Solved: Move rows to new work book based on a cell value.



rajesh nag
01-12-2009, 03:43 AM
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
01-16-2009, 07:07 AM
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. 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