Data Extraction

[JohnyG]

HI,

I need a small help. I need to write a macro for a workbook where in i have 3 sheets. Sheet1 is the consolidated sheet. Basis the value of column "D" the records needs to be moved to sheet "Done" and "Delayed". For eg. if Sheet1!D2 contains "Done" then that entire row moved as a last record in Sheet "Done", same will happen with "Delayed".

Attached is a sample file. Thanks in Advance for any help.

Johny

[JimmyTheHand]

Try this code. Because of reference to ThisWorkbook, the code must be in the same same workbook as the sheets.
[VBA]Sub MoveRecords()
Dim Rng As Range, c As Range
Dim Del As Worksheet, Don As Worksheet

Set Don = ThisWorkbook.Sheets("Done")
Set Del = ThisWorkbook.Sheets("Delayed")
Set Rng = ThisWorkbook.Sheets("Sheet1").Range("D2")
Set Rng = Range(Rng, Rng.End(xlDown))
For Each c In Rng.Cells
Select Case LCase(c)
Case "delayed": c.EntireRow.Copy Del.Range("A" & Del.Rows.Count).End(xlUp).Offset(1)
Case "done": c.EntireRow.Copy Don.Range("A" & Del.Rows.Count).End(xlUp).Offset(1)
End Select
Next c
Rng.EntireRow.Delete

End Sub[/VBA]

Jimmy

[mikerickson]

I think this will do what you want. It uses Advanced Filter to copy the rows to the new sheet. It also removes the transfered rows from the data base on Sheet 1.[VBA]Sub ArchiveDoneDelayed()
Dim dataRange As Range
Dim CritRange As Range
Dim DestinationRange As Range
Dim DestinationSheetName As Variant

Rem define work areas
With ThisWorkbook.Sheets("sheet1")
With .UsedRange
Set CritRange = .Cells(1, .Column + .Columns.Count + 1).Resize(2, 1)
End With
Set dataRange = Range(.Cells(1, 4), .Cells(.Rows.Count, 1).End(xlUp))
End With
If dataRange.Rows.Count > 1 Then

CritRange.Cells(1, 1).Value = "Status"

For Each DestinationSheetName In Array("Done", "Delayed")
Rem set criteria
CritRange.Cells(2, 1).Value = "'=" & DestinationSheetName

With Sheets(DestinationSheetName)
Set DestinationRange = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 4)

dataRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=CritRange, _
CopyToRange:=DestinationRange, Unique:=False

DestinationRange.Delete shift:=xlUp: Rem remove copied headers
End With
Next DestinationSheetName

Rem delete recently moved data from source data base
Set CritRange = CritRange.Resize(3, 1)
CritRange.Cells(3, 1) = "'=Done"
With dataRange
.Cells.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CritRange, Unique:=False
CritRange.EntireColumn.Delete
On Error Resume Next
.Offset(1, 0).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp
ThisWorkbook.Sheets("sheet1").ShowAllData
On Error GoTo 0
End With
End If
End Sub[/VBA]
If you don't want the deletion in the original data base, replace the indicated section with
[vba]CritRange.EntireColumn.Delete[/vba]

[JohnyG]

Thank you so much for your help..


Best Regards,

Johny