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
Blocked Profile - Apr 10, 2014 at 09:09 AM
Related:
- Vba rows copy
- Vba case like - Guide
- Number to words in excel formula without vba - Guide
- Vba create folder if not exist ✓ - Excel Forum
- Vba check if value is in array - Guide
- Vba color index - Guide
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
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
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
Mar 13, 2014 at 01:58 AM
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!