search for specific criteria in a column, then copy and paste to a new sheet in the next available row, and return to first sheet and delete rows with

[lizholguin]

Hi,

I have a spreadsheet that needs the following actions performed:

Main sheet (Active Jobs Jan 1 - Jun 30 2012) needs to have the rows of data removed that meet a set criteria (i.e. in column Y the criteria would be "complete")

I then need this series of data rows removed and pasted into the next available rows (in a "completed" archived worksheet that is ongoing).

I then need the original data in the main sheet removed, and then I also need it to loop through and continue this process until all data meeting that criteria is transferred.

Then it needs to have both sheets password protected and saved.

the code below is what I tried this time, but I'm stuck.

my alternate attempts were:
I've tried to cut and paste the info into the sheet, and it leaves blank rows in the main sheet and pastes it into the top two rows above the spreadsheet header instead of down in the body of the data range.

so now I'm trying to copy and paste, then return and delete the original data, but I keep getting stuck at the paste section onto the "completed" sheet.

Can someone take a look and help me try to get this to work properly please? or point me in the right direction please?

Heres my code:

Sub removeRows()

ActiveSheet.Unprotect
Sheets("Completed").Select
ActiveSheet.Unprotect
Sheets("Active Jobs Jan 1 - Jun 30 2012").Select

Dim MyRange As Range, copyRange As Range, C As Range
Dim MatchString As String, SearchColumn As String, ActiveColumn As String
Dim FirstAddress As String, NullCheck As String
Dim AC

'Extract active column as text
AC = Split(ActiveCell.EntireColumn.Address(, False), ":")
ActiveColumn = AC(0)

SearchColumn = InputBox("Enter Search Column - press Cancel to exit sub", "Row Copy Paste Code", ActiveColumn)

On Error Resume Next
Set MyRange = Columns(SearchColumn)
On Error GoTo 0

'If an invalid range is entered then exit
If MyRange Is Nothing Then Exit Sub

MatchString = InputBox("Enter Search string", "Row Copy Paste Code", ActiveCell.Value)
If MatchString = "" Then
NullCheck = InputBox("Do you really want to copy rows with empty cells?" & vbNewLine & vbNewLine & _
"Type Yes to do so, else code will exit", "Caution", "No")
If NullCheck <> "Yes" Then Exit Sub
End If

Application.ScreenUpdating = False

'to match the WHOLE text string
Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole)
'to match a PARTIAL text string use this line
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlpart)
'to match the case and of a WHOLE text string
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True)

If Not C Is Nothing Then
Set copyRange = C
FirstAddress = C.Address
Do
Set C = MyRange.FindNext(C)
Set copyRange = Union(copyRange, C)
Loop While FirstAddress <> C.Address
End If

'If there are valid matches then cut the rows
If Not copyRange Is Nothing Then copyRange.EntireRow.Copy

Application.ScreenUpdating = True

Sheets("Completed").Select

With Worksheets("completed")
.Range("A1").End(xlDown).Offset(1, 0).Select
'working down
.Range("A65536").End(xlUp).Offset(1, 0).Select
'working up
End With

Worksheets("completed").Cells.EntireRow.Paste

Application.ScreenUpdating = True

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True
Sheets("Active Jobs Jan 1 - Jun 30 2012").Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingRows:=True, AllowDeletingRows:=True, AllowFiltering:= _
True
ActiveWorkbook.Save

With Worksheets("active jobs jan 1 - jun 30 2012")


End With

'Extract active column as text
AC = Split(ActiveCell.EntireColumn.Address(, False), ":")
ActiveColumn = AC(0)

SearchColumn = InputBox("Enter Search Column - press Cancel to exit sub", "Row Delete Code", ActiveColumn)

On Error Resume Next
Set MyRange = Columns(SearchColumn)
On Error GoTo 0

'If an invalid range is entered then exit
If MyRange Is Nothing Then Exit Sub

MatchString = InputBox("Enter Search string", "Row Delete Code", ActiveCell.Value)
If MatchString = "" Then
NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _
"Type Yes to do so, else code will exit", "Caution", "No")
If NullCheck <> "Yes" Then Exit Sub
End If

Application.ScreenUpdating = False

'to match the WHOLE text string
Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole)
'to match a PARTIAL text string use this line
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlpart)
'to match the case and of a WHOLE text string
'Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True)

If Not C Is Nothing Then
Set DelRange = C
FirstAddress = C.Address
Do
Set C = MyRange.FindNext(C)
Set DelRange = Union(DelRange, C)
Loop While FirstAddress <> C.Address
End If

'If there are valid matches then delete the rows
If Not DelRange Is Nothing Then DelRange.EntireRow.Delete

Application.ScreenUpdating = True

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFiltering:=True

ActiveWorkbook.Save

Dim rng As Range

With Sheets("Data Dump")
Set rng = .Range("A7:G" & .Range("A7").End(xlDown).Row)
End With

wsPricing.Range("H" & Rows.Count).End(xlUp).Offset(1).Resize(rng.Rows.Count, 7).Value = rng.Value


End Sub



Thanks, L

 

[Trevor G]

Welcome to the Forum Liz,

Something like this would help you. First I would use a Filter on the Column to select all the rows with the criteria then copy the visible cells less the headings then select the archive sheet and use a ragne that is well down the sheet and use an xlup and then Offset 1 row to paste in the values and then return and delete what is left in the filter. An example is shown below. I haven't tested but hope you can see what I am suggesting. It only then requires to take the filters off and reset the passwords.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> clearfilterDelete()<br>Sheets("Main sheet (Active Jobs Jan 1 - Jun 30 2012)").Select<br>ActiveSheet.Range("$A$4:$CE$65536").AutoFilter Field:=25, Criteria1:= _<br>"=Completed"<br><SPAN style="color:#00007F">With</SPAN> ActiveSheet.AutoFilter.Range<br>.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>Sheets("Completed").Select<br>Range("65536").Select<br>Selection.End(xlUp).Select<br>ActiveCell.Offset(1, 0).Select<br>ActiveSheet.Paste<br>Sheets("Main sheet (Active Jobs Jan 1 - Jun 30 2012)").Activate<br><SPAN style="color:#00007F">With</SPAN> ActiveSheet.AutoFilter.Range<br>.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>

 

[lizholguin]

Thanks Trevor,

I will give it a try. my spreadsheet has the autofilter on it already so I'll just put that code in and see what happens.

Thanks again, L

 

[lizholguin]

Hi again,

I tried the code you gave me and it's hanging up on this line:

.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy

any idea why?

thanks, L

 

[Trevor G]

I have created a sheet with the names you are using and also added some records and used this code, it works. So I hope that this will work for you, if not perhaps showing some sample data will help find a solution for you.

<font face=Courier New><SPAN style="color:#00007F">Sub</SPAN> clearfilterDelete()<br>Application.DisplayAlerts = <SPAN style="color:#00007F">False</SPAN><br>Application.ScreenUpdating = <SPAN style="color:#00007F">False</SPAN><br>Sheets("Active Jobs Jan 1 - Jun 30 2012").Select<br>Selection.AutoFilter<br>ActiveSheet.Range("$A$1:$Z$65536").AutoFilter Field:=26, Criteria1:="Completed"<br><SPAN style="color:#00007F">With</SPAN> ActiveSheet.AutoFilter.Range<br>.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>Sheets("Completed").Select<br>Range("A65536").Select<br>Selection.End(xlUp).Select<br>ActiveCell.Offset(1, 0).Select<br>ActiveSheet.Paste<br>Sheets("Active Jobs Jan 1 - Jun 30 2012").Activate<br><SPAN style="color:#00007F">With</SPAN> ActiveSheet.AutoFilter.Range<br>.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Delete<br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">With</SPAN><br>Rows(1).Select<br> Selection.AutoFilter<br>Application.DisplayAlerts = <SPAN style="color:#00007F">True</SPAN><br>Application.ScreenUpdating = <SPAN style="color:#00007F">True</SPAN><br><br><SPAN style="color:#00007F">End</SPAN> <SPAN style="color:#00007F">Sub</SPAN></FONT>