lizholguin
New Member
- Joined
- Apr 23, 2012
- Messages
- 3
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
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