Sam Coombes
asked on
Copy a row
I need to be able to copy a row from sheet 1 to sheet 2 and remove the row from sheet 1. If a cell in AB is true the entire row needs to be copied once a button is pressed.
ASKER
That's great but I am confused why there is an error with line 11.
Also I have renamed sheet one blueteq
Any ideas
Also I have renamed sheet one blueteq
Any ideas
What error you get?
It's hard to tell unless you upload a sample workbook. I assume sheet2 doesn't contain merged cells.
It's hard to tell unless you upload a sample workbook. I assume sheet2 doesn't contain merged cells.
ASKER
Hi
That's no problem I have attached a copy of the spreadsheet.
Thank you so much for your assistance.
That's no problem I have attached a copy of the spreadsheet.
Thank you so much for your assistance.
ASKER
Sorry here its is
Blueteqemail-v1.xlsm
Blueteqemail-v1.xlsm
Okay try this....
Sub CopyRow()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
Set sws = Sheets("Blueteq")
Set dws = Sheets("Sheet2")
lr = sws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
With sws.Range("AB5:AB" & lr)
.AutoFilter field:=1, Criteria1:="True"
If .SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
sws.Range("AB6:AB" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy dws.Range("A" & Rows.Count).End(3)(2)
sws.Range("AB6:AB" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
.AutoFilter
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Either you clear the filter from Row4 before running the code or try the tweaked code...
Sub CopyRow()
Dim sws As Worksheet, dws As Worksheet
Dim lr As Long
Application.EnableEvents = False
Application.ScreenUpdating = False
Set sws = Sheets("Blueteq")
Set dws = Sheets("Sheet2")
lr = sws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sws.AutoFilterMode = False
With sws.Range("AB5:AB" & lr)
.AutoFilter field:=1, Criteria1:="True"
If .SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
sws.Range("AB6:AB" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Copy dws.Range("A" & Rows.Count).End(3)(2)
sws.Range("AB6:AB" & lr).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
.AutoFilter
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
ASKER
That's fantastic thank you
You're welcome Sam! Glad to help.
ASKER
Great solution but it is causing Excel to crash any ideas ?
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Fantastic thank you
Open in new window