Copying the entire row using VBA

Closed
ScullyMulder Posts 2 Registration date Wednesday March 12, 2014 Status Member Last seen March 13, 2014 - Mar 12, 2014 at 04:06 AM
 Blocked Profile - Apr 10, 2014 at 09:09 AM
Hi!
I need a code that will automatically copy the entire row to another sheet (same file) when a condition has been satisfied.

See the sample below

A B C D E F
info1 info2 info3 info4 info5 Production
info1 info2 info3 info4 info5 Dispatched
info1 info2 info3 info4 info5 Completed
info1 info2 info3 info4 info5 Rejected
info1 info2 info3 info4 info5 Hold/Cancelled
info1 info2 info3 info4 info5 Tracking No

If, I fill up the column F with "Production", the entire row should be copied in the Sheet named Production. The same with Dispatched, Completed and so on...

Thanks in advance for your help.

14 responses

venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 811
Mar 13, 2014 at 12:06 AM
introduce the first row as headings row in sheet 1

hdng1 hdng2 hdng3 hdng4 hdng5 hdng6
info1 info2 info3 info4 info5 Production
info1 info2 info3 info4 info5 Dispatched
info1 info2 info3 info4 info5 Completed
info1 info2 info3 info4 info5 Rejected
info1 info2 info3 info4 info5 Hold/Cancelled
info1 info2 info3 info4 info5 Tracking no


2 macros and one function are given elow

run only "test"

undo macro is remove the effect of macro

Sub test()
Dim r6 As Range, rdata As Range, filt As Range, cfilt As Range, x
Dim j As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False


With Worksheets("sheet1")
Range(.Range("A1").End(xlDown).Offset(1, 0), .Cells(Rows.Count, "A")).EntireRow.Delete
Set r6 = Range(.Range("F1"), .Range("F1").End(xlDown))
Set filt = .Range("A1").End(xlDown).Offset(5, 0)
Set rdata = .Range("A1").CurrentRegion
r6.AdvancedFilter xlFilterCopy, , filt, True
Set filt = Range(filt.Offset(1, 0), filt.End(xlDown))
For Each cfilt In filt
x = cfilt
rdata.AutoFilter field:=6, Criteria1:=x
rdata.Offset(1, 0).Resize(rdata.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
On Error Resume Next

If Exists(Worksheets(x)) Then
GoTo nextstep
Else
Worksheets.Add
ActiveSheet.Name = x
End If
nextstep:
With Worksheets(x)
.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
End With
.AutoFilterMode = False
Next cfilt
With Worksheets("sheet1")
Range(.Range("A1").End(xlDown).Offset(1, 0), .Cells(Rows.Count, "A")).EntireRow.Delete
End With

MsgBox "macro done"
Application.ScreenUpdating = True
Application.CutCopyMode = False
Application.DisplayAlerts = True
End With

End Sub


Function Exists(sh As Worksheet)
Dim ws As Worksheet
On Error Resume Next
Set ws = sh
If Err.Number <> 0 Then
Exists = False
Else
Exists = True
End If
End Function


Sub undo()
Application.DisplayAlerts = False
Dim j As Integer
For j = Worksheets.Count To 1 Step -1
If Worksheets(j).Name <> "Sheet1" Then Worksheets(j).Delete
Next j
With Worksheets("sheet1")
Range(.Range("A1").End(xlDown).Offset(1, 0), .Cells(Rows.Count, "A")).EntireRow.Delete
End With
End Sub
0
ScullyMulder Posts 2 Registration date Wednesday March 12, 2014 Status Member Last seen March 13, 2014
Mar 13, 2014 at 01:58 AM
Hi, thank you for the code....
I'am not very much familiar with VBA, but I have copy and paste this code to the "View Code" of the sheet but nothing happened. Can you please tell me what am I missing out?
Thanks in advance!
0